diff options
Diffstat (limited to 'gcc-4.8.1/gcc/fortran/trans-array.c')
-rw-r--r-- | gcc-4.8.1/gcc/fortran/trans-array.c | 8823 |
1 files changed, 0 insertions, 8823 deletions
diff --git a/gcc-4.8.1/gcc/fortran/trans-array.c b/gcc-4.8.1/gcc/fortran/trans-array.c deleted file mode 100644 index 75fed2f65..000000000 --- a/gcc-4.8.1/gcc/fortran/trans-array.c +++ /dev/null @@ -1,8823 +0,0 @@ -/* Array translation routines - Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - and Steven Bosscher <s.bosscher@student.tudelft.nl> - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -<http://www.gnu.org/licenses/>. */ - -/* trans-array.c-- Various array related code, including scalarization, - allocation, initialization and other support routines. */ - -/* How the scalarizer works. - In gfortran, array expressions use the same core routines as scalar - expressions. - First, a Scalarization State (SS) chain is built. This is done by walking - the expression tree, and building a linear list of the terms in the - expression. As the tree is walked, scalar subexpressions are translated. - - The scalarization parameters are stored in a gfc_loopinfo structure. - First the start and stride of each term is calculated by - gfc_conv_ss_startstride. During this process the expressions for the array - descriptors and data pointers are also translated. - - If the expression is an assignment, we must then resolve any dependencies. - In Fortran all the rhs values of an assignment must be evaluated before - any assignments take place. This can require a temporary array to store the - values. We also require a temporary when we are passing array expressions - or vector subscripts as procedure parameters. - - Array sections are passed without copying to a temporary. These use the - scalarizer to determine the shape of the section. The flag - loop->array_parameter tells the scalarizer that the actual values and loop - variables will not be required. - - The function gfc_conv_loop_setup generates the scalarization setup code. - It determines the range of the scalarizing loop variables. If a temporary - is required, this is created and initialized. Code for scalar expressions - taken outside the loop is also generated at this time. Next the offset and - scaling required to translate from loop variables to array indices for each - term is calculated. - - A call to gfc_start_scalarized_body marks the start of the scalarized - expression. This creates a scope and declares the loop variables. Before - calling this gfc_make_ss_chain_used must be used to indicate which terms - will be used inside this loop. - - The scalar gfc_conv_* functions are then used to build the main body of the - scalarization loop. Scalarization loop variables and precalculated scalar - values are automatically substituted. Note that gfc_advance_se_ss_chain - must be used, rather than changing the se->ss directly. - - For assignment expressions requiring a temporary two sub loops are - generated. The first stores the result of the expression in the temporary, - the second copies it to the result. A call to - gfc_trans_scalarized_loop_boundary marks the end of the main loop code and - the start of the copying loop. The temporary may be less than full rank. - - Finally gfc_trans_scalarizing_loops is called to generate the implicit do - loops. The loops are added to the pre chain of the loopinfo. The post - chain may still contain cleanup code. - - After the loop code has been added into its parent scope gfc_cleanup_loop - is called to free all the SS allocated by the scalarizer. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "gimple.h" /* For create_tmp_var_name. */ -#include "diagnostic-core.h" /* For internal_error/fatal_error. */ -#include "flags.h" -#include "gfortran.h" -#include "constructor.h" -#include "trans.h" -#include "trans-stmt.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -#include "dependency.h" - -static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); - -/* The contents of this structure aren't actually used, just the address. */ -static gfc_ss gfc_ss_terminator_var; -gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; - - -static tree -gfc_array_dataptr_type (tree desc) -{ - return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); -} - - -/* Build expressions to access the members of an array descriptor. - It's surprisingly easy to mess up here, so never access - an array descriptor by "brute force", always use these - functions. This also avoids problems if we change the format - of an array descriptor. - - To understand these magic numbers, look at the comments - before gfc_build_array_type() in trans-types.c. - - The code within these defines should be the only code which knows the format - of an array descriptor. - - Any code just needing to read obtain the bounds of an array should use - gfc_conv_array_* rather than the following functions as these will return - know constant values, and work with arrays which do not have descriptors. - - Don't forget to #undef these! */ - -#define DATA_FIELD 0 -#define OFFSET_FIELD 1 -#define DTYPE_FIELD 2 -#define DIMENSION_FIELD 3 -#define CAF_TOKEN_FIELD 4 - -#define STRIDE_SUBFIELD 0 -#define LBOUND_SUBFIELD 1 -#define UBOUND_SUBFIELD 2 - -/* This provides READ-ONLY access to the data field. The field itself - doesn't have the proper type. */ - -tree -gfc_conv_descriptor_data_get (tree desc) -{ - tree field, type, t; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = TYPE_FIELDS (type); - gcc_assert (DATA_FIELD == 0); - - t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, - field, NULL_TREE); - t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t); - - return t; -} - -/* This provides WRITE access to the data field. - - TUPLES_P is true if we are generating tuples. - - This function gets called through the following macros: - gfc_conv_descriptor_data_set - gfc_conv_descriptor_data_set. */ - -void -gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) -{ - tree field, type, t; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = TYPE_FIELDS (type); - gcc_assert (DATA_FIELD == 0); - - t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, - field, NULL_TREE); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value)); -} - - -/* This provides address access to the data field. This should only be - used by array allocation, passing this on to the runtime. */ - -tree -gfc_conv_descriptor_data_addr (tree desc) -{ - tree field, type, t; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = TYPE_FIELDS (type); - gcc_assert (DATA_FIELD == 0); - - t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, - field, NULL_TREE); - return gfc_build_addr_expr (NULL_TREE, t); -} - -static tree -gfc_conv_descriptor_offset (tree desc) -{ - tree type; - tree field; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - -tree -gfc_conv_descriptor_offset_get (tree desc) -{ - return gfc_conv_descriptor_offset (desc); -} - -void -gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, - tree value) -{ - tree t = gfc_conv_descriptor_offset (desc); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - - -tree -gfc_conv_descriptor_dtype (tree desc) -{ - tree field; - tree type; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - - -tree -gfc_conv_descriptor_rank (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); -} - - -tree -gfc_get_descriptor_dimension (tree desc) -{ - tree type, field; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); - gcc_assert (field != NULL_TREE - && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - - -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) -{ - tree tmp; - - tmp = gfc_get_descriptor_dimension (desc); - - return gfc_build_array_ref (tmp, dim, NULL); -} - - -tree -gfc_conv_descriptor_token (tree desc) -{ - tree type; - tree field; - - type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE); - gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); - field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - - -static tree -gfc_conv_descriptor_stride (tree desc, tree dim) -{ - tree tmp; - tree field; - - tmp = gfc_conv_descriptor_dimension (desc, dim); - field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, STRIDE_SUBFIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); - return tmp; -} - -tree -gfc_conv_descriptor_stride_get (tree desc, tree dim) -{ - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - if (integer_zerop (dim) - && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) - return gfc_index_one_node; - - return gfc_conv_descriptor_stride (desc, dim); -} - -void -gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_stride (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_lbound (tree desc, tree dim) -{ - tree tmp; - tree field; - - tmp = gfc_conv_descriptor_dimension (desc, dim); - field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, LBOUND_SUBFIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); - return tmp; -} - -tree -gfc_conv_descriptor_lbound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_lbound (desc, dim); -} - -void -gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_lbound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_ubound (tree desc, tree dim) -{ - tree tmp; - tree field; - - tmp = gfc_conv_descriptor_dimension (desc, dim); - field = TYPE_FIELDS (TREE_TYPE (tmp)); - field = gfc_advance_chain (field, UBOUND_SUBFIELD); - gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); - return tmp; -} - -tree -gfc_conv_descriptor_ubound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_ubound (desc, dim); -} - -void -gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_ubound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -/* Build a null array descriptor constructor. */ - -tree -gfc_build_null_descriptor (tree type) -{ - tree field; - tree tmp; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (DATA_FIELD == 0); - field = TYPE_FIELDS (type); - - /* Set a NULL data pointer. */ - tmp = build_constructor_single (type, field, null_pointer_node); - TREE_CONSTANT (tmp) = 1; - /* All other fields are ignored. */ - - return tmp; -} - - -/* Modify a descriptor such that the lbound of a given dimension is the value - specified. This also updates ubound and offset accordingly. */ - -void -gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, - int dim, tree new_lbound) -{ - tree offs, ubound, lbound, stride; - tree diff, offs_diff; - - new_lbound = fold_convert (gfc_array_index_type, new_lbound); - - offs = gfc_conv_descriptor_offset_get (desc); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); - - /* Get difference (new - old) by which to shift stuff. */ - diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - new_lbound, lbound); - - /* Shift ubound and offset accordingly. This has to be done before - updating the lbound, as they depend on the lbound expression! */ - ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, diff); - gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); - offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - diff, stride); - offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offs, offs_diff); - gfc_conv_descriptor_offset_set (block, desc, offs); - - /* Finally set lbound to value we want. */ - gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); -} - - -/* Cleanup those #defines. */ - -#undef DATA_FIELD -#undef OFFSET_FIELD -#undef DTYPE_FIELD -#undef DIMENSION_FIELD -#undef CAF_TOKEN_FIELD -#undef STRIDE_SUBFIELD -#undef LBOUND_SUBFIELD -#undef UBOUND_SUBFIELD - - -/* Mark a SS chain as used. Flags specifies in which loops the SS is used. - flags & 1 = Main loop body. - flags & 2 = temp copy loop. */ - -void -gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) -{ - for (; ss != gfc_ss_terminator; ss = ss->next) - ss->info->useflags = flags; -} - - -/* Free a gfc_ss chain. */ - -void -gfc_free_ss_chain (gfc_ss * ss) -{ - gfc_ss *next; - - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->next; - gfc_free_ss (ss); - ss = next; - } -} - - -static void -free_ss_info (gfc_ss_info *ss_info) -{ - int n; - - ss_info->refcount--; - if (ss_info->refcount > 0) - return; - - gcc_assert (ss_info->refcount == 0); - - switch (ss_info->type) - { - case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss_info->data.array.subscript[n]) - gfc_free_ss_chain (ss_info->data.array.subscript[n]); - break; - - default: - break; - } - - free (ss_info); -} - - -/* Free a SS. */ - -void -gfc_free_ss (gfc_ss * ss) -{ - free_ss_info (ss->info); - free (ss); -} - - -/* Creates and initializes an array type gfc_ss struct. */ - -gfc_ss * -gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = type; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a temporary type gfc_ss struct. */ - -gfc_ss * -gfc_get_temp_ss (tree type, tree string_length, int dimen) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_TEMP; - ss_info->string_length = string_length; - ss_info->data.temp.type = type; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = gfc_ss_terminator; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a scalar type gfc_ss struct. */ - -gfc_ss * -gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_SCALAR; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - - return ss; -} - - -/* Free all the SS associated with a loop. */ - -void -gfc_cleanup_loop (gfc_loopinfo * loop) -{ - gfc_loopinfo *loop_next, **ploop; - gfc_ss *ss; - gfc_ss *next; - - ss = loop->ss; - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->loop_chain; - gfc_free_ss (ss); - ss = next; - } - - /* Remove reference to self in the parent loop. */ - if (loop->parent) - for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) - if (*ploop == loop) - { - *ploop = loop->next; - break; - } - - /* Free non-freed nested loops. */ - for (loop = loop->nested; loop; loop = loop_next) - { - loop_next = loop->next; - gfc_cleanup_loop (loop); - free (loop); - } -} - - -static void -set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) -{ - int n; - - for (; ss != gfc_ss_terminator; ss = ss->next) - { - ss->loop = loop; - - if (ss->info->type == GFC_SS_SCALAR - || ss->info->type == GFC_SS_REFERENCE - || ss->info->type == GFC_SS_TEMP) - continue; - - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss->info->data.array.subscript[n] != NULL) - set_ss_loop (ss->info->data.array.subscript[n], loop); - } -} - - -/* Associate a SS chain with a loop. */ - -void -gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) -{ - gfc_ss *ss; - gfc_loopinfo *nested_loop; - - if (head == gfc_ss_terminator) - return; - - set_ss_loop (head, loop); - - ss = head; - for (; ss && ss != gfc_ss_terminator; ss = ss->next) - { - if (ss->nested_ss) - { - nested_loop = ss->nested_ss->loop; - - /* More than one ss can belong to the same loop. Hence, we add the - loop to the chain only if it is different from the previously - added one, to avoid duplicate nested loops. */ - if (nested_loop != loop->nested) - { - gcc_assert (nested_loop->parent == NULL); - nested_loop->parent = loop; - - gcc_assert (nested_loop->next == NULL); - nested_loop->next = loop->nested; - loop->nested = nested_loop; - } - else - gcc_assert (nested_loop->parent == loop); - } - - if (ss->next == gfc_ss_terminator) - ss->loop_chain = loop->ss; - else - ss->loop_chain = ss->next; - } - gcc_assert (ss == gfc_ss_terminator); - loop->ss = head; -} - - -/* Generate an initializer for a static pointer or allocatable array. */ - -void -gfc_trans_static_array_pointer (gfc_symbol * sym) -{ - tree type; - - gcc_assert (TREE_STATIC (sym->backend_decl)); - /* Just zero the data member. */ - type = TREE_TYPE (sym->backend_decl); - DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); -} - - -/* If the bounds of SE's loop have not yet been set, see if they can be - determined from array spec AS, which is the array spec of a called - function. MAPPING maps the callee's dummy arguments to the values - that the caller is passing. Add any initialization and finalization - code to SE. */ - -void -gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, - gfc_se * se, gfc_array_spec * as) -{ - int n, dim, total_dim; - gfc_se tmpse; - gfc_ss *ss; - tree lower; - tree upper; - tree tmp; - - total_dim = 0; - - if (!as || as->type != AS_EXPLICIT) - return; - - for (ss = se->ss; ss; ss = ss->parent) - { - total_dim += ss->loop->dimen; - for (n = 0; n < ss->loop->dimen; n++) - { - /* The bound is known, nothing to do. */ - if (ss->loop->to[n] != NULL_TREE) - continue; - - dim = ss->dim[n]; - gcc_assert (dim < as->rank); - gcc_assert (ss->loop->dimen <= as->rank); - - /* Evaluate the lower bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - lower = fold_convert (gfc_array_index_type, tmpse.expr); - - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - ss->loop->to[n] = tmp; - } - } - - gcc_assert (total_dim == as->rank); -} - - -/* Generate code to allocate an array temporary, or create a variable to - hold the data. If size is NULL, zero the descriptor so that the - callee will allocate the array. If DEALLOC is true, also generate code to - free the array afterwards. - - If INITIAL is not NULL, it is packed using internal_pack and the result used - as data instead of allocating a fresh, unitialized area of memory. - - Initialization code is added to PRE and finalization code to POST. - DYNAMIC is true if the caller may want to extend the array later - using realloc. This prevents us from putting the array on the stack. */ - -static void -gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, - gfc_array_info * info, tree size, tree nelem, - tree initial, bool dynamic, bool dealloc) -{ - tree tmp; - tree desc; - bool onstack; - - desc = info->descriptor; - info->offset = gfc_index_zero_node; - if (size == NULL_TREE || integer_zerop (size)) - { - /* A callee allocated array. */ - gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); - onstack = FALSE; - } - else - { - /* Allocate the temporary. */ - onstack = !dynamic && initial == NULL_TREE - && (gfc_option.flag_stack_arrays - || gfc_can_put_var_on_stack (size)); - - if (onstack) - { - /* Make a temporary variable to hold the data. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), - nelem, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, pre); - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, - tmp); - tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), - tmp); - tmp = gfc_create_var (tmp, "A"); - /* If we're here only because of -fstack-arrays we have to - emit a DECL_EXPR to make the gimplifier emit alloca calls. */ - if (!gfc_can_put_var_on_stack (size)) - gfc_add_expr_to_block (pre, - fold_build1_loc (input_location, - DECL_EXPR, TREE_TYPE (tmp), - tmp)); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - else - { - /* Allocate memory to hold the data or call internal_pack. */ - if (initial == NULL_TREE) - { - tmp = gfc_call_malloc (pre, NULL, size); - tmp = gfc_evaluate_now (tmp, pre); - } - else - { - tree packed; - tree source_data; - tree was_packed; - stmtblock_t do_copying; - - tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); - tmp = TREE_TYPE (tmp); /* The descriptor itself. */ - tmp = gfc_get_element_type (tmp); - gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); - packed = gfc_create_var (build_pointer_type (tmp), "data"); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, initial); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (pre, packed, tmp); - - tmp = build_fold_indirect_ref_loc (input_location, - initial); - source_data = gfc_conv_descriptor_data_get (tmp); - - /* internal_pack may return source->data without any allocation - or copying if it is already packed. If that's the case, we - need to allocate and copy manually. */ - - gfc_start_block (&do_copying); - tmp = gfc_call_malloc (&do_copying, NULL, size); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (&do_copying, packed, tmp); - tmp = gfc_build_memcpy_call (packed, source_data, size); - gfc_add_expr_to_block (&do_copying, tmp); - - was_packed = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, packed, - source_data); - tmp = gfc_finish_block (&do_copying); - tmp = build3_v (COND_EXPR, was_packed, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (pre, tmp); - - tmp = fold_convert (pvoid_type_node, packed); - } - - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - } - info->data = gfc_conv_descriptor_data_get (desc); - - /* The offset is zero because we create temporaries with a zero - lower bound. */ - gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); - - if (dealloc && !onstack) - { - /* Free the temporary. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp)); - gfc_add_expr_to_block (post, tmp); - } -} - - -/* Get the scalarizer array dimension corresponding to actual array dimension - given by ARRAY_DIM. - - For example, if SS represents the array ref a(1,:,:,1), it is a - bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, - and 1 for ARRAY_DIM=2. - If SS represents transpose(a(:,1,1,:)), it is again a bidimensional - scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for - ARRAY_DIM=3. - If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer - array. If called on the inner ss, the result would be respectively 0,1,2 for - ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 - for ARRAY_DIM=1,2. */ - -static int -get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) -{ - int array_ref_dim; - int n; - - array_ref_dim = 0; - - for (; ss; ss = ss->parent) - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] < array_dim) - array_ref_dim++; - - return array_ref_dim; -} - - -static gfc_ss * -innermost_ss (gfc_ss *ss) -{ - while (ss->nested_ss != NULL) - ss = ss->nested_ss; - - return ss; -} - - - -/* Get the array reference dimension corresponding to the given loop dimension. - It is different from the true array dimension given by the dim array in - the case of a partial array reference (i.e. a(:,:,1,:) for example) - It is different from the loop dimension in the case of a transposed array. - */ - -static int -get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) -{ - return get_scalarizer_dim_for_array_dim (innermost_ss (ss), - ss->dim[loop_dim]); -} - - -/* Generate code to create and initialize the descriptor for a temporary - array. This is used for both temporaries needed by the scalarizer, and - functions returning arrays. Adjusts the loop variables to be - zero-based, and calculates the loop bounds for callee allocated arrays. - Allocate the array unless it's callee allocated (we have a callee - allocated array if 'callee_alloc' is true, or if loop->to[n] is - NULL_TREE for any n). Also fills in the descriptor, data and offset - fields of info if known. Returns the size of the array, or NULL for a - callee allocated array. - - 'eltype' == NULL signals that the temporary should be a class object. - The 'initial' expression is used to obtain the size of the dynamic - type; otherwise the allocation and initialisation proceeds as for any - other expression - - PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for - gfc_trans_allocate_array_storage. */ - -tree -gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, - tree eltype, tree initial, bool dynamic, - bool dealloc, bool callee_alloc, locus * where) -{ - gfc_loopinfo *loop; - gfc_ss *s; - gfc_array_info *info; - tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; - tree type; - tree desc; - tree tmp; - tree size; - tree nelem; - tree cond; - tree or_expr; - tree class_expr = NULL_TREE; - int n, dim, tmp_dim; - int total_dim = 0; - - /* This signals a class array for which we need the size of the - dynamic type. Generate an eltype and then the class expression. */ - if (eltype == NULL_TREE && initial) - { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); - class_expr = build_fold_indirect_ref_loc (input_location, initial); - eltype = TREE_TYPE (class_expr); - eltype = gfc_get_element_type (eltype); - /* Obtain the structure (class) expression. */ - class_expr = TREE_OPERAND (class_expr, 0); - gcc_assert (class_expr); - } - - memset (from, 0, sizeof (from)); - memset (to, 0, sizeof (to)); - - info = &ss->info->data.array; - - gcc_assert (ss->dimen > 0); - gcc_assert (ss->loop->dimen == ss->dimen); - - if (gfc_option.warn_array_temp && where) - gfc_warning ("Creating array temporary at %L", where); - - /* Set the lower bound to zero. */ - for (s = ss; s; s = s->parent) - { - loop = s->loop; - - total_dim += loop->dimen; - for (n = 0; n < loop->dimen; n++) - { - dim = s->dim[n]; - - /* Callee allocated arrays may not have a known bound yet. */ - if (loop->to[n]) - loop->to[n] = gfc_evaluate_now ( - fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]), - pre); - loop->from[n] = gfc_index_zero_node; - - /* We have just changed the loop bounds, we must clear the - corresponding specloop, so that delta calculation is not skipped - later in gfc_set_delta. */ - loop->specloop[n] = NULL; - - /* We are constructing the temporary's descriptor based on the loop - dimensions. As the dimensions may be accessed in arbitrary order - (think of transpose) the size taken from the n'th loop may not map - to the n'th dimension of the array. We need to reconstruct loop - infos in the right order before using it to set the descriptor - bounds. */ - tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); - from[tmp_dim] = loop->from[n]; - to[tmp_dim] = loop->to[n]; - - info->delta[dim] = gfc_index_zero_node; - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - } - - /* Initialize the descriptor. */ - type = - gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, - GFC_ARRAY_UNKNOWN, true); - desc = gfc_create_var (type, "atmp"); - GFC_DECL_PACKED_ARRAY (desc) = 1; - - info->descriptor = desc; - size = gfc_index_one_node; - - /* Fill in the array dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - - /* - Fill in the bounds and stride. This is a packed array, so: - - size = 1; - for (n = 0; n < rank; n++) - { - stride[n] = size - delta = ubound[n] + 1 - lbound[n]; - size = size * delta; - } - size = size * sizeof(element); - */ - - or_expr = NULL_TREE; - - /* If there is at least one null loop->to[n], it is a callee allocated - array. */ - for (n = 0; n < total_dim; n++) - if (to[n] == NULL_TREE) - { - size = NULL_TREE; - break; - } - - if (size == NULL_TREE) - for (s = ss; s; s = s->parent) - for (n = 0; n < s->loop->dimen; n++) - { - dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); - - /* For a callee allocated array express the loop bounds in terms - of the descriptor fields. */ - tmp = fold_build2_loc (input_location, - MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); - s->loop->to[n] = tmp; - } - else - { - for (n = 0; n < total_dim; n++) - { - /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); - - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], - gfc_index_zero_node); - - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - to[n], gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, - tmp, gfc_index_zero_node); - cond = gfc_evaluate_now (cond, pre); - - if (n == 0) - or_expr = cond; - else - or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, or_expr, cond); - - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - size = gfc_evaluate_now (size, pre); - } - } - - /* Get the size of the array. */ - if (size && !callee_alloc) - { - tree elemsize; - /* If or_expr is true, then the extent in at least one - dimension is zero and the size is set to zero. */ - size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - or_expr, gfc_index_zero_node, size); - - nelem = size; - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - else - elemsize = gfc_vtable_size_get (class_expr); - - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, elemsize); - } - else - { - nelem = size; - size = NULL_TREE; - } - - gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, - dynamic, dealloc); - - while (ss->parent) - ss = ss->parent; - - if (ss->dimen > ss->loop->temp_dim) - ss->loop->temp_dim = ss->dimen; - - return size; -} - - -/* Return the number of iterations in a loop that starts at START, - ends at END, and has step STEP. */ - -static tree -gfc_get_iteration_count (tree start, tree end, tree step) -{ - tree tmp; - tree type; - - type = TREE_TYPE (step); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, - build_int_cst (type, 1)); - tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, - build_int_cst (type, 0)); - return fold_convert (gfc_array_index_type, tmp); -} - - -/* Extend the data in array DESC by EXTRA elements. */ - -static void -gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) -{ - tree arg0, arg1; - tree tmp; - tree size; - tree ubound; - - if (integer_zerop (extra)) - return; - - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); - - /* Add EXTRA to the upper bound. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, extra); - gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); - - /* Get the value of the current data pointer. */ - arg0 = gfc_conv_descriptor_data_get (desc); - - /* Calculate the new array size. */ - size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, gfc_index_one_node); - arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), - fold_convert (size_type_node, size)); - - /* Call the realloc() function. */ - tmp = gfc_call_realloc (pblock, arg0, arg1); - gfc_conv_descriptor_data_set (pblock, desc, tmp); -} - - -/* Return true if the bounds of iterator I can only be determined - at run time. */ - -static inline bool -gfc_iterator_has_dynamic_bounds (gfc_iterator * i) -{ - return (i->start->expr_type != EXPR_CONSTANT - || i->end->expr_type != EXPR_CONSTANT - || i->step->expr_type != EXPR_CONSTANT); -} - - -/* Split the size of constructor element EXPR into the sum of two terms, - one of which can be determined at compile time and one of which must - be calculated at run time. Set *SIZE to the former and return true - if the latter might be nonzero. */ - -static bool -gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) -{ - if (expr->expr_type == EXPR_ARRAY) - return gfc_get_array_constructor_size (size, expr->value.constructor); - else if (expr->rank > 0) - { - /* Calculate everything at run time. */ - mpz_set_ui (*size, 0); - return true; - } - else - { - /* A single element. */ - mpz_set_ui (*size, 1); - return false; - } -} - - -/* Like gfc_get_array_constructor_element_size, but applied to the whole - of array constructor C. */ - -static bool -gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) -{ - gfc_constructor *c; - gfc_iterator *i; - mpz_t val; - mpz_t len; - bool dynamic; - - mpz_set_ui (*size, 0); - mpz_init (len); - mpz_init (val); - - dynamic = false; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - i = c->iterator; - if (i && gfc_iterator_has_dynamic_bounds (i)) - dynamic = true; - else - { - dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); - if (i) - { - /* Multiply the static part of the element size by the - number of iterations. */ - mpz_sub (val, i->end->value.integer, i->start->value.integer); - mpz_fdiv_q (val, val, i->step->value.integer); - mpz_add_ui (val, val, 1); - if (mpz_sgn (val) > 0) - mpz_mul (len, len, val); - else - mpz_set_ui (len, 0); - } - mpz_add (*size, *size, len); - } - } - mpz_clear (len); - mpz_clear (val); - return dynamic; -} - - -/* Make sure offset is a variable. */ - -static void -gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, - tree * offsetvar) -{ - /* We should have already created the offset variable. We cannot - create it here because we may be in an inner scope. */ - gcc_assert (*offsetvar != NULL_TREE); - gfc_add_modify (pblock, *offsetvar, *poffset); - *poffset = *offsetvar; - TREE_USED (*offsetvar) = 1; -} - - -/* Variables needed for bounds-checking. */ -static bool first_len; -static tree first_len_val; -static bool typespec_chararray_ctor; - -static void -gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, - tree offset, gfc_se * se, gfc_expr * expr) -{ - tree tmp; - - gfc_conv_expr (se, expr); - - /* Store the value. */ - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_descriptor_data_get (desc)); - tmp = gfc_build_array_ref (tmp, offset, NULL); - - if (expr->ts.type == BT_CHARACTER) - { - int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); - tree esize; - - esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); - esize = fold_convert (gfc_charlen_type_node, esize); - esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_charlen_type_node, esize, - build_int_cst (gfc_charlen_type_node, - gfc_character_kinds[i].bit_size / 8)); - - gfc_conv_string_parameter (se); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - { - /* The temporary is an array of pointers. */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - else - { - /* The temporary is an array of string values. */ - tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, - se->string_length, se->expr, expr->ts.kind); - } - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) - { - if (first_len) - { - gfc_add_modify (&se->pre, first_len_val, - se->string_length); - first_len = false; - } - else - { - /* Verify that all constructor elements are of the same - length. */ - tree cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, first_len_val, - se->string_length); - gfc_trans_runtime_check - (true, false, cond, &se->pre, &expr->where, - "Different CHARACTER lengths (%ld/%ld) in array constructor", - fold_convert (long_integer_type_node, first_len_val), - fold_convert (long_integer_type_node, se->string_length)); - } - } - } - else - { - /* TODO: Should the frontend already have done this conversion? */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - - gfc_add_block_to_block (pblock, &se->pre); - gfc_add_block_to_block (pblock, &se->post); -} - - -/* Add the contents of an array to the constructor. DYNAMIC is as for - gfc_trans_array_constructor_value. */ - -static void -gfc_trans_array_constructor_subarray (stmtblock_t * pblock, - tree type ATTRIBUTE_UNUSED, - tree desc, gfc_expr * expr, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - gfc_se se; - gfc_ss *ss; - gfc_loopinfo loop; - stmtblock_t body; - tree tmp; - tree size; - int n; - - /* We need this to be a variable so we can increment it. */ - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - gfc_init_se (&se, NULL); - - /* Walk the array expression. */ - ss = gfc_walk_expr (expr); - gcc_assert (ss != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - /* Make sure the constructed array has room for the new data. */ - if (dynamic) - { - /* Set SIZE to the total number of elements in the subarray. */ - size = gfc_index_one_node; - for (n = 0; n < loop.dimen; n++) - { - tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], - gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - - /* Grow the constructed array by SIZE elements. */ - gfc_grow_array (&loop.pre, desc, size); - } - - /* Make the loop body. */ - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &body); - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = ss; - - gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); - gcc_assert (se.ss == gfc_ss_terminator); - - /* Increment the offset. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *poffset, gfc_index_one_node); - gfc_add_modify (&body, *poffset, tmp); - - /* Finish the loop. */ - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&loop.pre, &loop.post); - tmp = gfc_finish_block (&loop.pre); - gfc_add_expr_to_block (pblock, tmp); - - gfc_cleanup_loop (&loop); -} - - -/* Assign the values to the elements of an array constructor. DYNAMIC - is true if descriptor DESC only contains enough data for the static - size calculated by gfc_get_array_constructor_size. When true, memory - for the dynamic parts must be allocated using realloc. */ - -static void -gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor_base base, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - tree tmp; - tree start = NULL_TREE; - tree end = NULL_TREE; - tree step = NULL_TREE; - stmtblock_t body; - gfc_se se; - mpz_t size; - gfc_constructor *c; - - tree shadow_loopvar = NULL_TREE; - gfc_saved_var saved_loopvar; - - mpz_init (size); - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - /* If this is an iterator or an array, the offset must be a variable. */ - if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - /* Shadowing the iterator avoids changing its value and saves us from - keeping track of it. Further, it makes sure that there's always a - backend-decl for the symbol, even if there wasn't one before, - e.g. in the case of an iterator that appears in a specification - expression in an interface mapping. */ - if (c->iterator) - { - gfc_symbol *sym; - tree type; - - /* Evaluate loop bounds before substituting the loop variable - in case they depend on it. Such a case is invalid, but it is - not more expensive to do the right thing here. - See PR 44354. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->start); - gfc_add_block_to_block (pblock, &se.pre); - start = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->end); - gfc_add_block_to_block (pblock, &se.pre); - end = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->step); - gfc_add_block_to_block (pblock, &se.pre); - step = gfc_evaluate_now (se.expr, pblock); - - sym = c->iterator->var->symtree->n.sym; - type = gfc_typenode_for_spec (&sym->ts); - - shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); - gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); - } - - gfc_start_block (&body); - - if (c->expr->expr_type == EXPR_ARRAY) - { - /* Array constructors can be nested. */ - gfc_trans_array_constructor_value (&body, type, desc, - c->expr->value.constructor, - poffset, offsetvar, dynamic); - } - else if (c->expr->rank > 0) - { - gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, - poffset, offsetvar, dynamic); - } - else - { - /* This code really upsets the gimplifier so don't bother for now. */ - gfc_constructor *p; - HOST_WIDE_INT n; - HOST_WIDE_INT size; - - p = c; - n = 0; - while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) - { - p = gfc_constructor_next (p); - n++; - } - if (n < 4) - { - /* Scalar values. */ - gfc_init_se (&se, NULL); - gfc_trans_array_ctor_element (&body, desc, *poffset, - &se, c->expr); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - *poffset, gfc_index_one_node); - } - else - { - /* Collect multiple scalar constants into a constructor. */ - vec<constructor_elt, va_gc> *v = NULL; - tree init; - tree bound; - tree tmptype; - HOST_WIDE_INT idx = 0; - - p = c; - /* Count the number of consecutive scalar constants. */ - while (p && !(p->iterator - || p->expr->expr_type != EXPR_CONSTANT)) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, p->expr); - - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - /* For constant character array constructors we build - an array of pointers. */ - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr - (gfc_get_pchar_type (p->expr->ts.kind), - se.expr); - - CONSTRUCTOR_APPEND_ELT (v, - build_int_cst (gfc_array_index_type, - idx++), - se.expr); - c = p; - p = gfc_constructor_next (p); - } - - bound = size_int (n - 1); - /* Create an array type to hold them. */ - tmptype = build_range_type (gfc_array_index_type, - gfc_index_zero_node, bound); - tmptype = build_array_type (type, tmptype); - - init = build_constructor (tmptype, v); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - /* Create a static variable to hold the data. */ - tmp = gfc_create_var (tmptype, "data"); - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - init = tmp; - - /* Use BUILTIN_MEMCPY to assign the values. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = build_fold_indirect_ref_loc (input_location, - tmp); - tmp = gfc_build_array_ref (tmp, *poffset, NULL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - init = gfc_build_addr_expr (NULL_TREE, init); - - size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); - bound = build_int_cst (size_type_node, n * size); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, tmp, init, bound); - gfc_add_expr_to_block (&body, tmp); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *poffset, - build_int_cst (gfc_array_index_type, n)); - } - if (!INTEGER_CST_P (*poffset)) - { - gfc_add_modify (&body, *offsetvar, *poffset); - *poffset = *offsetvar; - } - } - - /* The frontend should already have done any expansions - at compile-time. */ - if (!c->iterator) - { - /* Pass the code as is. */ - tmp = gfc_finish_block (&body); - gfc_add_expr_to_block (pblock, tmp); - } - else - { - /* Build the implied do-loop. */ - stmtblock_t implied_do_block; - tree cond; - tree exit_label; - tree loopbody; - tree tmp2; - - loopbody = gfc_finish_block (&body); - - /* Create a new block that holds the implied-do loop. A temporary - loop-variable is used. */ - gfc_start_block(&implied_do_block); - - /* Initialize the loop. */ - gfc_add_modify (&implied_do_block, shadow_loopvar, start); - - /* If this array expands dynamically, and the number of iterations - is not constant, we won't have allocated space for the static - part of C->EXPR's size. Do that now. */ - if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) - { - /* Get the number of iterations. */ - tmp = gfc_get_iteration_count (shadow_loopvar, end, step); - - /* Get the static part of C->EXPR's size. */ - gfc_get_array_constructor_element_size (&size, c->expr); - tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - - /* Grow the array by TMP * TMP2 elements. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, tmp2); - gfc_grow_array (&implied_do_block, desc, tmp); - } - - /* Generate the loop body. */ - exit_label = gfc_build_label_decl (NULL_TREE); - gfc_start_block (&body); - - /* Generate the exit condition. Depending on the sign of - the step variable we have to generate the correct - comparison. */ - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, - step, build_int_cst (TREE_TYPE (step), 0)); - cond = fold_build3_loc (input_location, COND_EXPR, - boolean_type_node, tmp, - fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, shadow_loopvar, end), - fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, shadow_loopvar, end)); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - - /* The main loop body. */ - gfc_add_expr_to_block (&body, loopbody); - - /* Increase loop variable by step. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (shadow_loopvar), shadow_loopvar, - step); - gfc_add_modify (&body, shadow_loopvar, tmp); - - /* Finish the loop. */ - tmp = gfc_finish_block (&body); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Finish the implied-do loop. */ - tmp = gfc_finish_block(&implied_do_block); - gfc_add_expr_to_block(pblock, tmp); - - gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); - } - } - mpz_clear (size); -} - - -/* A catch-all to obtain the string length for anything that is not - a substring of non-constant length, a constant, array or variable. */ - -static void -get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) -{ - gfc_se se; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - if (!e->ref && e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - /* This is easy. */ - gfc_conv_const_charlen (e->ts.u.cl); - *len = e->ts.u.cl->backend_decl; - } - else - { - /* Otherwise, be brutal even if inefficient. */ - gfc_init_se (&se, NULL); - - /* No function call, in case of side effects. */ - se.no_function_call = 1; - if (e->rank == 0) - gfc_conv_expr (&se, e); - else - gfc_conv_expr_descriptor (&se, e); - - /* Fix the value. */ - *len = gfc_evaluate_now (se.string_length, &se.pre); - - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (block, &se.post); - - e->ts.u.cl->backend_decl = *len; - } -} - - -/* Figure out the string length of a variable reference expression. - Used by get_array_ctor_strlen. */ - -static void -get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) -{ - gfc_ref *ref; - gfc_typespec *ts; - mpz_t char_len; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - ts = &expr->symtree->n.sym->ts; - for (ref = expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - /* Array references don't change the string length. */ - break; - - case REF_COMPONENT: - /* Use the length of the component. */ - ts = &ref->u.c.component->ts; - break; - - case REF_SUBSTRING: - if (ref->u.ss.start->expr_type != EXPR_CONSTANT - || ref->u.ss.end->expr_type != EXPR_CONSTANT) - { - /* Note that this might evaluate expr. */ - get_array_ctor_all_strlen (block, expr, len); - return; - } - mpz_init_set_ui (char_len, 1); - mpz_add (char_len, char_len, ref->u.ss.end->value.integer); - mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); - *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind); - *len = convert (gfc_charlen_type_node, *len); - mpz_clear (char_len); - return; - - default: - gcc_unreachable (); - } - } - - *len = ts->u.cl->backend_decl; -} - - -/* Figure out the string length of a character array constructor. - If len is NULL, don't calculate the length; this happens for recursive calls - when a sub-array-constructor is an element but not at the first position, - so when we're not interested in the length. - Returns TRUE if all elements are character constants. */ - -bool -get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) -{ - gfc_constructor *c; - bool is_const; - - is_const = TRUE; - - if (gfc_constructor_first (base) == NULL) - { - if (len) - *len = build_int_cstu (gfc_charlen_type_node, 0); - return is_const; - } - - /* Loop over all constructor elements to find out is_const, but in len we - want to store the length of the first, not the last, element. We can - of course exit the loop as soon as is_const is found to be false. */ - for (c = gfc_constructor_first (base); - c && is_const; c = gfc_constructor_next (c)) - { - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - if (len && !(*len && INTEGER_CST_P (*len))) - *len = build_int_cstu (gfc_charlen_type_node, - c->expr->value.character.length); - break; - - case EXPR_ARRAY: - if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) - is_const = false; - break; - - case EXPR_VARIABLE: - is_const = false; - if (len) - get_array_ctor_var_strlen (block, c->expr, len); - break; - - default: - is_const = false; - if (len) - get_array_ctor_all_strlen (block, c->expr, len); - break; - } - - /* After the first iteration, we don't want the length modified. */ - len = NULL; - } - - return is_const; -} - -/* Check whether the array constructor C consists entirely of constant - elements, and if so returns the number of those elements, otherwise - return zero. Note, an empty or NULL array constructor returns zero. */ - -unsigned HOST_WIDE_INT -gfc_constant_array_constructor_p (gfc_constructor_base base) -{ - unsigned HOST_WIDE_INT nelem = 0; - - gfc_constructor *c = gfc_constructor_first (base); - while (c) - { - if (c->iterator - || c->expr->rank > 0 - || c->expr->expr_type != EXPR_CONSTANT) - return 0; - c = gfc_constructor_next (c); - nelem++; - } - return nelem; -} - - -/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, - and the tree type of it's elements, TYPE, return a static constant - variable that is compile-time initialized. */ - -tree -gfc_build_constant_array_constructor (gfc_expr * expr, tree type) -{ - tree tmptype, init, tmp; - HOST_WIDE_INT nelem; - gfc_constructor *c; - gfc_array_spec as; - gfc_se se; - int i; - vec<constructor_elt, va_gc> *v = NULL; - - /* First traverse the constructor list, converting the constants - to tree to build an initializer. */ - nelem = 0; - c = gfc_constructor_first (expr->value.constructor); - while (c) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, c->expr); - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), - se.expr); - CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), - se.expr); - c = gfc_constructor_next (c); - nelem++; - } - - /* Next determine the tree type for the array. We use the gfortran - front-end's gfc_get_nodesc_array_type in order to create a suitable - GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ - - memset (&as, 0, sizeof (gfc_array_spec)); - - as.rank = expr->rank; - as.type = AS_EXPLICIT; - if (!expr->shape) - { - as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, nelem - 1); - } - else - for (i = 0; i < expr->rank; i++) - { - int tmp = (int) mpz_get_si (expr->shape[i]); - as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, tmp - 1); - } - - tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); - - /* as is not needed anymore. */ - for (i = 0; i < as.rank + as.corank; i++) - { - gfc_free_expr (as.lower[i]); - gfc_free_expr (as.upper[i]); - } - - init = build_constructor (tmptype, v); - - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - - tmp = gfc_create_var (tmptype, "A"); - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - - return tmp; -} - - -/* Translate a constant EXPR_ARRAY array constructor for the scalarizer. - This mostly initializes the scalarizer state info structure with the - appropriate values to directly use the array created by the function - gfc_build_constant_array_constructor. */ - -static void -trans_constant_array_constructor (gfc_ss * ss, tree type) -{ - gfc_array_info *info; - tree tmp; - int i; - - tmp = gfc_build_constant_array_constructor (ss->info->expr, type); - - info = &ss->info->data.array; - - info->descriptor = tmp; - info->data = gfc_build_addr_expr (NULL_TREE, tmp); - info->offset = gfc_index_zero_node; - - for (i = 0; i < ss->dimen; i++) - { - info->delta[i] = gfc_index_zero_node; - info->start[i] = gfc_index_zero_node; - info->end[i] = gfc_index_zero_node; - info->stride[i] = gfc_index_one_node; - } -} - - -static int -get_rank (gfc_loopinfo *loop) -{ - int rank; - - rank = 0; - for (; loop; loop = loop->parent) - rank += loop->dimen; - - return rank; -} - - -/* Helper routine of gfc_trans_array_constructor to determine if the - bounds of the loop specified by LOOP are constant and simple enough - to use with trans_constant_array_constructor. Returns the - iteration count of the loop if suitable, and NULL_TREE otherwise. */ - -static tree -constant_array_constructor_loop_size (gfc_loopinfo * l) -{ - gfc_loopinfo *loop; - tree size = gfc_index_one_node; - tree tmp; - int i, total_dim; - - total_dim = get_rank (l); - - for (loop = l; loop; loop = loop->parent) - { - for (i = 0; i < loop->dimen; i++) - { - /* If the bounds aren't constant, return NULL_TREE. */ - if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) - return NULL_TREE; - if (!integer_zerop (loop->from[i])) - { - /* Only allow nonzero "from" in one-dimensional arrays. */ - if (total_dim != 1) - return NULL_TREE; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[i], loop->from[i]); - } - else - tmp = loop->to[i]; - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - } - - return size; -} - - -static tree * -get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) -{ - gfc_ss *ss; - int n; - - gcc_assert (array->nested_ss == NULL); - - for (ss = array; ss; ss = ss->parent) - for (n = 0; n < ss->loop->dimen; n++) - if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) - return &(ss->loop->to[n]); - - gcc_unreachable (); -} - - -static gfc_loopinfo * -outermost_loop (gfc_loopinfo * loop) -{ - while (loop->parent != NULL) - loop = loop->parent; - - return loop; -} - - -/* Array constructors are handled by constructing a temporary, then using that - within the scalarization loop. This is not optimal, but seems by far the - simplest method. */ - -static void -trans_array_constructor (gfc_ss * ss, locus * where) -{ - gfc_constructor_base c; - tree offset; - tree offsetvar; - tree desc; - tree type; - tree tmp; - tree *loop_ubound0; - bool dynamic; - bool old_first_len, old_typespec_chararray_ctor; - tree old_first_len_val; - gfc_loopinfo *loop, *outer_loop; - gfc_ss_info *ss_info; - gfc_expr *expr; - gfc_ss *s; - - /* Save the old values for nested checking. */ - old_first_len = first_len; - old_first_len_val = first_len_val; - old_typespec_chararray_ctor = typespec_chararray_ctor; - - loop = ss->loop; - outer_loop = outermost_loop (loop); - ss_info = ss->info; - expr = ss_info->expr; - - /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no - typespec was given for the array constructor. */ - typespec_chararray_ctor = (expr->ts.u.cl - && expr->ts.u.cl->length_from_typespec); - - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) - { - first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); - first_len = true; - } - - gcc_assert (ss->dimen == ss->loop->dimen); - - c = expr->value.constructor; - if (expr->ts.type == BT_CHARACTER) - { - bool const_string; - - /* get_array_ctor_strlen walks the elements of the constructor, if a - typespec was given, we already know the string length and want the one - specified there. */ - if (typespec_chararray_ctor && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - { - gfc_se length_se; - - const_string = false; - gfc_init_se (&length_se, NULL); - gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = length_se.expr; - gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); - gfc_add_block_to_block (&outer_loop->post, &length_se.post); - } - else - const_string = get_array_ctor_strlen (&outer_loop->pre, c, - &ss_info->string_length); - - /* Complex character array constructors should have been taken care of - and not end up here. */ - gcc_assert (ss_info->string_length); - - expr->ts.u.cl->backend_decl = ss_info->string_length; - - type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); - if (const_string) - type = build_pointer_type (type); - } - else - type = gfc_typenode_for_spec (&expr->ts); - - /* See if the constructor determines the loop bounds. */ - dynamic = false; - - loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); - - if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) - { - /* We have a multidimensional parameter. */ - for (s = ss; s; s = s->parent) - { - int n; - for (n = 0; n < s->loop->dimen; n++) - { - s->loop->from[n] = gfc_index_zero_node; - s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], - gfc_index_integer_kind); - s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - s->loop->to[n], - gfc_index_one_node); - } - } - } - - if (*loop_ubound0 == NULL_TREE) - { - mpz_t size; - - /* We should have a 1-dimensional, zero-based loop. */ - gcc_assert (loop->parent == NULL && loop->nested == NULL); - gcc_assert (loop->dimen == 1); - gcc_assert (integer_zerop (loop->from[0])); - - /* Split the constructor size into a static part and a dynamic part. - Allocate the static size up-front and record whether the dynamic - size might be nonzero. */ - mpz_init (size); - dynamic = gfc_get_array_constructor_size (&size, c); - mpz_sub_ui (size, size, 1); - loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - mpz_clear (size); - } - - /* Special case constant array constructors. */ - if (!dynamic) - { - unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); - if (nelem > 0) - { - tree size = constant_array_constructor_loop_size (loop); - if (size && compare_tree_int (size, nelem) == 0) - { - trans_constant_array_constructor (ss, type); - goto finish; - } - } - } - - gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, - NULL_TREE, dynamic, true, false, where); - - desc = ss_info->data.array.descriptor; - offset = gfc_index_zero_node; - offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); - TREE_NO_WARNING (offsetvar) = 1; - TREE_USED (offsetvar) = 0; - gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, - &offset, &offsetvar, dynamic); - - /* If the array grows dynamically, the upper bound of the loop variable - is determined by the array's final upper bound. */ - if (dynamic) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offsetvar, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); - if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL) - gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); - else - *loop_ubound0 = tmp; - } - - if (TREE_USED (offsetvar)) - pushdecl (offsetvar); - else - gcc_assert (INTEGER_CST_P (offset)); - -#if 0 - /* Disable bound checking for now because it's probably broken. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - gcc_unreachable (); - } -#endif - -finish: - /* Restore old values of globals. */ - first_len = old_first_len; - first_len_val = old_first_len_val; - typespec_chararray_ctor = old_typespec_chararray_ctor; -} - - -/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is - called after evaluating all of INFO's vector dimensions. Go through - each such vector dimension and see if we can now fill in any missing - loop bounds. */ - -static void -set_vector_loop_bounds (gfc_ss * ss) -{ - gfc_loopinfo *loop, *outer_loop; - gfc_array_info *info; - gfc_se se; - tree tmp; - tree desc; - tree zero; - int n; - int dim; - - outer_loop = outermost_loop (ss->loop); - - info = &ss->info->data.array; - - for (; ss; ss = ss->parent) - { - loop = ss->loop; - - for (n = 0; n < loop->dimen; n++) - { - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR - || loop->to[n] != NULL) - continue; - - /* Loop variable N indexes vector dimension DIM, and we don't - yet know the upper bound of loop variable N. Set it to the - difference between the vector's upper and lower bounds. */ - gcc_assert (loop->from[n] == gfc_index_zero_node); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - - gfc_init_se (&se, NULL); - desc = info->subscript[dim]->info->data.array.descriptor; - zero = gfc_rank_cst[0]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, zero), - gfc_conv_descriptor_lbound_get (desc, zero)); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - loop->to[n] = tmp; - } - } -} - - -/* Add the pre and post chains for all the scalar expressions in a SS chain - to loop. This is called after the loop parameters have been calculated, - but before the actual scalarizing loops. */ - -static void -gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, - locus * where) -{ - gfc_loopinfo *nested_loop, *outer_loop; - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - int n; - - /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, - arguments could get evaluated multiple times. */ - if (ss->is_alloc_lhs) - return; - - outer_loop = outermost_loop (loop); - - /* TODO: This can generate bad code if there are ordering dependencies, - e.g., a callee allocated function and an unknown size constructor. */ - gcc_assert (ss != NULL); - - for (; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gcc_assert (ss); - - /* Cross loop arrays are handled from within the most nested loop. */ - if (ss->nested_ss != NULL) - continue; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - switch (ss_info->type) - { - case GFC_SS_SCALAR: - /* Scalar expression. Evaluate this now. This includes elemental - dimension indices, but not array section bounds. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - - if (expr->ts.type != BT_CHARACTER) - { - /* Move the evaluation of scalar expressions outside the - scalarization loop, except for WHERE assignments. */ - if (subscript) - se.expr = convert(gfc_array_index_type, se.expr); - if (!ss_info->where) - se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); - gfc_add_block_to_block (&outer_loop->pre, &se.post); - } - else - gfc_add_block_to_block (&outer_loop->post, &se.post); - - ss_info->data.scalar.value = se.expr; - ss_info->string_length = se.string_length; - break; - - case GFC_SS_REFERENCE: - /* Scalar argument to elemental procedure. */ - gfc_init_se (&se, NULL); - if (ss_info->can_be_null_ref) - { - /* If the actual argument can be absent (in other words, it can - be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ - gfc_conv_expr_reference (&se, expr); - } - else - { - /* Otherwise, evaluate the argument outside the loop and pass - a reference to the value. */ - gfc_conv_expr (&se, expr); - } - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - if (gfc_is_class_scalar_expr (expr)) - /* This is necessary because the dynamic type will always be - large than the declared type. In consequence, assigning - the value to a temporary could segfault. - OOP-TODO: see if this is generally correct or is the value - has to be written to an allocated temporary, whose address - is passed via ss_info. */ - ss_info->data.scalar.value = se.expr; - else - ss_info->data.scalar.value = gfc_evaluate_now (se.expr, - &outer_loop->pre); - - ss_info->string_length = se.string_length; - break; - - case GFC_SS_SECTION: - /* Add the expressions for scalar and vector subscripts. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (info->subscript[n]) - gfc_add_loop_ss_code (loop, info->subscript[n], true, where); - - set_vector_loop_bounds (ss); - break; - - case GFC_SS_VECTOR: - /* Get the vector's descriptor and store it in SS. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - info->descriptor = se.expr; - break; - - case GFC_SS_INTRINSIC: - gfc_add_intrinsic_ss_code (loop, ss); - break; - - case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - ss_info->string_length = se.string_length; - break; - - case GFC_SS_CONSTRUCTOR: - if (expr->ts.type == BT_CHARACTER - && ss_info->string_length == NULL - && expr->ts.u.cl - && expr->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = se.expr; - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - } - trans_array_constructor (ss, where); - break; - - case GFC_SS_TEMP: - case GFC_SS_COMPONENT: - /* Do nothing. These are handled elsewhere. */ - break; - - default: - gcc_unreachable (); - } - } - - if (!subscript) - for (nested_loop = loop->nested; nested_loop; - nested_loop = nested_loop->next) - gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); -} - - -/* Translate expressions for the descriptor and data pointer of a SS. */ -/*GCC ARRAYS*/ - -static void -gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) -{ - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - tree tmp; - - ss_info = ss->info; - info = &ss_info->data.array; - - /* Get the descriptor for the array to be scalarized. */ - gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr_lhs (&se, ss_info->expr); - gfc_add_block_to_block (block, &se.pre); - info->descriptor = se.expr; - ss_info->string_length = se.string_length; - - if (base) - { - /* Also the data pointer. */ - tmp = gfc_conv_array_data (se.expr); - /* If this is a variable or address of a variable we use it directly. - Otherwise we must evaluate it now to avoid breaking dependency - analysis by pulling the expressions for elemental array indices - inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))))) - tmp = gfc_evaluate_now (tmp, block); - info->data = tmp; - - tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); - - /* Make absolutely sure that the saved_offset is indeed saved - so that the variable is still accessible after the loops - are translated. */ - info->saved_offset = info->offset; - } -} - - -/* Initialize a gfc_loopinfo structure. */ - -void -gfc_init_loopinfo (gfc_loopinfo * loop) -{ - int n; - - memset (loop, 0, sizeof (gfc_loopinfo)); - gfc_init_block (&loop->pre); - gfc_init_block (&loop->post); - - /* Initially scalarize in order and default to no loop reversal. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - { - loop->order[n] = n; - loop->reverse[n] = GFC_INHIBIT_REVERSE; - } - - loop->ss = gfc_ss_terminator; -} - - -/* Copies the loop variable info to a gfc_se structure. Does not copy the SS - chain. */ - -void -gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) -{ - se->loop = loop; -} - - -/* Return an expression for the data pointer of an array. */ - -tree -gfc_conv_array_data (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - { - if (TREE_CODE (type) == POINTER_TYPE) - return descriptor; - else - { - /* Descriptorless arrays. */ - return gfc_build_addr_expr (NULL_TREE, descriptor); - } - } - else - return gfc_conv_descriptor_data_get (descriptor); -} - - -/* Return an expression for the base offset of an array. */ - -tree -gfc_conv_array_offset (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - return GFC_TYPE_ARRAY_OFFSET (type); - else - return gfc_conv_descriptor_offset_get (descriptor); -} - - -/* Get an expression for the array stride. */ - -tree -gfc_conv_array_stride (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - /* For descriptorless arrays use the array size. */ - tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the lower bound. */ - -tree -gfc_conv_array_lbound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the upper bound. */ - -tree -gfc_conv_array_ubound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - /* This should only ever happen when passing an assumed shape array - as an actual parameter. The value will never be used. */ - if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) - return gfc_index_zero_node; - - tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Generate code to perform an array index bound check. */ - -static tree -trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, - locus * where, bool check_upper) -{ - tree fault; - tree tmp_lo, tmp_up; - tree descriptor; - char *msg; - const char * name = NULL; - - if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) - return index; - - descriptor = ss->info->data.array.descriptor; - - index = gfc_evaluate_now (index, &se->pre); - - /* We find a name for the error message. */ - name = ss->info->expr->symtree->n.sym->name; - gcc_assert (name != NULL); - - if (TREE_CODE (descriptor) == VAR_DECL) - name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); - - /* If upper bound is present, include both bounds in the error message. */ - if (check_upper) - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - tmp_up = gfc_conv_array_ubound (descriptor, n); - - if (name) - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", n+1, name); - else - asprintf (&msg, "Index '%%ld' of dimension %d " - "outside of expected range (%%ld:%%ld)", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, - index, tmp_up); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - free (msg); - } - else - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - - if (name) - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, name); - else - asprintf (&msg, "Index '%%ld' of dimension %d " - "below lower bound of %%ld", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo)); - free (msg); - } - - return index; -} - - -/* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. - DIM is the array dimension, I is the loop dimension. */ - -static tree -conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, - gfc_array_ref * ar, tree stride) -{ - gfc_array_info *info; - tree index; - tree desc; - tree data; - - info = &ss->info->data.array; - - /* Get the index into the array for this dimension. */ - if (ar) - { - gcc_assert (ar->type != AR_ELEMENT); - switch (ar->dimen_type[dim]) - { - case DIMEN_THIS_IMAGE: - gcc_unreachable (); - break; - case DIMEN_ELEMENT: - /* Elemental dimension. */ - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_SCALAR); - /* We've already translated this value outside the loop. */ - index = info->subscript[dim]->info->data.scalar.value; - - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_VECTOR: - gcc_assert (info && se->loop); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - desc = info->subscript[dim]->info->data.array.descriptor; - - /* Get a zero-based index into the vector. */ - index = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - se->loop->loopvar[i], se->loop->from[i]); - - /* Multiply the index by the stride. */ - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, gfc_conv_array_stride (desc, 0)); - - /* Read the vector to get an index into info->descriptor. */ - data = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (desc)); - index = gfc_build_array_ref (data, index, NULL); - index = gfc_evaluate_now (index, &se->pre); - index = fold_convert (gfc_array_index_type, index); - - /* Do any bounds checking on the final info->descriptor index. */ - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_RANGE: - /* Scalarized dimension. */ - gcc_assert (info && se->loop); - - /* Multiply the loop variable by the stride and delta. */ - index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[dim])) - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, index, - info->stride[dim]); - if (!integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, - info->delta[dim]); - break; - - default: - gcc_unreachable (); - } - } - else - { - /* Temporary array or derived type component. */ - gcc_assert (se->loop); - index = se->loop->loopvar[se->loop->order[i]]; - - /* Pointer functions can have stride[0] different from unity. - Use the stride returned by the function call and stored in - the descriptor for the temporary. */ - if (se->ss && se->ss->info->type == GFC_SS_FUNCTION - && se->ss->info->expr - && se->ss->info->expr->symtree - && se->ss->info->expr->symtree->n.sym->result - && se->ss->info->expr->symtree->n.sym->result->attr.pointer) - stride = gfc_conv_descriptor_stride_get (info->descriptor, - gfc_rank_cst[dim]); - - if (!integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, info->delta[dim]); - } - - /* Multiply by the stride. */ - if (!integer_onep (stride)) - index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - index, stride); - - return index; -} - - -/* Build a scalarized array reference using the vptr 'size'. */ - -static bool -build_class_array_ref (gfc_se *se, tree base, tree index) -{ - tree type; - tree size; - tree offset; - tree decl; - tree tmp; - gfc_expr *expr = se->ss->info->expr; - gfc_ref *ref; - gfc_ref *class_ref; - gfc_typespec *ts; - - if (expr == NULL || expr->ts.type != BT_CLASS) - return false; - - if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) - ts = &expr->symtree->n.sym->ts; - else - ts = NULL; - class_ref = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && ref->next && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type != AR_ELEMENT) - { - ts = &ref->u.c.component->ts; - class_ref = ref; - break; - } - } - - if (ts == NULL) - return false; - - if (class_ref == NULL) - decl = expr->symtree->n.sym->backend_decl; - else - { - /* Remove everything after the last class reference, convert the - expression and then recover its tailend once more. */ - gfc_se tmpse; - ref = class_ref->next; - class_ref->next = NULL; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, expr); - decl = tmpse.expr; - class_ref->next = ref; - } - - size = gfc_vtable_size_get (decl); - - /* Build the address of the element. */ - type = TREE_TYPE (TREE_TYPE (base)); - size = fold_convert (TREE_TYPE (index), size); - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, size); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - - /* Return the element in the se expression. */ - se->expr = build_fold_indirect_ref_loc (input_location, tmp); - return true; -} - - -/* Build a scalarized reference to an array. */ - -static void -gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) -{ - gfc_array_info *info; - tree decl = NULL_TREE; - tree index; - tree tmp; - gfc_ss *ss; - gfc_expr *expr; - int n; - - ss = se->ss; - expr = ss->info->expr; - info = &ss->info->data.array; - if (ar) - n = se->loop->order[0]; - else - n = 0; - - index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); - /* Add the offset for this dimension to the stored offset for all other - dimensions. */ - if (!integer_zerop (info->offset)) - index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - index, info->offset); - - if (expr && is_subref_array (expr)) - decl = expr->symtree->n.sym->backend_decl; - - tmp = build_fold_indirect_ref_loc (input_location, info->data); - - /* Use the vptr 'size' field to access a class the element of a class - array. */ - if (build_class_array_ref (se, tmp, index)) - return; - - se->expr = gfc_build_array_ref (tmp, index, decl); -} - - -/* Translate access of temporary array. */ - -void -gfc_conv_tmp_array_ref (gfc_se * se) -{ - se->string_length = se->ss->info->string_length; - gfc_conv_scalarized_array_ref (se, NULL); - gfc_advance_se_ss_chain (se); -} - -/* Add T to the offset pair *OFFSET, *CST_OFFSET. */ - -static void -add_to_offset (tree *cst_offset, tree *offset, tree t) -{ - if (TREE_CODE (t) == INTEGER_CST) - *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); - else - { - if (!integer_zerop (*offset)) - *offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *offset, t); - else - *offset = t; - } -} - - -static tree -build_array_ref (tree desc, tree offset, tree decl) -{ - tree tmp; - tree type; - - /* Class container types do not always have the GFC_CLASS_TYPE_P - but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && TREE_CODE (desc) == COMPONENT_REF) - { - type = TREE_TYPE (TREE_OPERAND (desc, 0)); - if (TYPE_CANONICAL (type) - && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - type = TYPE_CANONICAL (type); - } - else - type = NULL; - - /* Class array references need special treatment because the assigned - type size needs to be used to point to the element. */ - if (type && GFC_CLASS_TYPE_P (type)) - { - type = gfc_get_element_type (TREE_TYPE (desc)); - tmp = TREE_OPERAND (desc, 0); - tmp = gfc_get_class_array_ref (offset, tmp); - tmp = fold_convert (build_pointer_type (type), tmp); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; - } - - tmp = gfc_conv_array_data (desc); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); - return tmp; -} - - -/* Build an array reference. se->expr already holds the array descriptor. - This should be either a variable, indirect variable reference or component - reference. For arrays which do not have a descriptor, se->expr will be - the data pointer. - a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ - -void -gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, - locus * where) -{ - int n; - tree offset, cst_offset; - tree tmp; - tree stride; - gfc_se indexse; - gfc_se tmpse; - - if (ar->dimen == 0) - { - gcc_assert (ar->codimen); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); - else - { - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) - && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - /* Use the actual tree type and not the wrapped coarray. */ - if (!se->want_pointer) - se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), - se->expr); - } - - return; - } - - /* Handle scalarized references separately. */ - if (ar->type != AR_ELEMENT) - { - gfc_conv_scalarized_array_ref (se, ar); - gfc_advance_se_ss_chain (se); - return; - } - - cst_offset = offset = gfc_index_zero_node; - add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr)); - - /* Calculate the offsets from all the dimensions. Make sure to associate - the final offset so that we form a chain of loop invariant summands. */ - for (n = ar->dimen - 1; n >= 0; n--) - { - /* Calculate the index for this dimension. */ - gfc_init_se (&indexse, se); - gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &indexse.pre); - - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - /* Check array bounds. */ - tree cond; - char *msg; - - /* Evaluate the indexse.expr only once. */ - indexse.expr = save_expr (indexse.expr); - - /* Lower bound. */ - tmp = gfc_conv_array_lbound (se->expr, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - indexse.expr, tmp); - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - - /* Upper bound, but not for the last dimension of assumed-size - arrays. */ - if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) - { - tmp = gfc_conv_array_ubound (se->expr, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, indexse.expr, tmp); - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "above upper bound of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - } - } - - /* Multiply the index by the stride. */ - stride = gfc_conv_array_stride (se->expr, n); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - indexse.expr, stride); - - /* And add it to the total. */ - add_to_offset (&cst_offset, &offset, tmp); - } - - if (!integer_zerop (cst_offset)) - offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, cst_offset); - - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); -} - - -/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's - LOOP_DIM dimension (if any) to array's offset. */ - -static void -add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, - gfc_array_ref *ar, int array_dim, int loop_dim) -{ - gfc_se se; - gfc_array_info *info; - tree stride, index; - - info = &ss->info->data.array; - - gfc_init_se (&se, NULL); - se.loop = loop; - se.expr = info->descriptor; - stride = gfc_conv_array_stride (info->descriptor, array_dim); - index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride); - gfc_add_block_to_block (pblock, &se.pre); - - info->offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - info->offset, index); - info->offset = gfc_evaluate_now (info->offset, pblock); -} - - -/* Generate the code to be executed immediately before entering a - scalarization loop. */ - -static void -gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, - stmtblock_t * pblock) -{ - tree stride; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_ss_type ss_type; - gfc_ss *ss, *pss; - gfc_loopinfo *ploop; - gfc_array_ref *ar; - int i; - - /* This code will be executed before entering the scalarization loop - for this dimension. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - ss_info = ss->info; - - if ((ss_info->useflags & flag) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - info = &ss_info->data.array; - - gcc_assert (dim < ss->dimen); - gcc_assert (ss->dimen == loop->dimen); - - if (info->ref) - ar = &info->ref->u.ar; - else - ar = NULL; - - if (dim == loop->dimen - 1 && loop->parent != NULL) - { - /* If we are in the outermost dimension of this loop, the previous - dimension shall be in the parent loop. */ - gcc_assert (ss->parent != NULL); - - pss = ss->parent; - ploop = loop->parent; - - /* ss and ss->parent are about the same array. */ - gcc_assert (ss_info == pss->info); - } - else - { - ploop = loop; - pss = ss; - } - - if (dim == loop->dimen - 1) - i = 0; - else - i = dim + 1; - - /* For the time being, there is no loop reordering. */ - gcc_assert (i == ploop->order[i]); - i = ploop->order[i]; - - if (dim == loop->dimen - 1 && loop->parent == NULL) - { - stride = gfc_conv_array_stride (info->descriptor, - innermost_ss (ss)->dim[i]); - - /* Calculate the stride of the innermost loop. Hopefully this will - allow the backend optimizers to do their stuff more effectively. - */ - info->stride0 = gfc_evaluate_now (stride, pblock); - - /* For the outermost loop calculate the offset due to any - elemental dimensions. It will have been initialized with the - base offset of the array. */ - if (info->ref) - { - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - continue; - - add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1); - } - } - } - else - /* Add the offset for the previous loop dimension. */ - add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); - - /* Remember this offset for the second loop. */ - if (dim == loop->temp_dim - 1 && loop->parent == NULL) - info->saved_offset = info->offset; - } -} - - -/* Start a scalarized expression. Creates a scope and declares loop - variables. */ - -void -gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) -{ - int dim; - int n; - int flags; - - gcc_assert (!loop->array_parameter); - - for (dim = loop->dimen - 1; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - /* Create the loop variable. */ - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); - - if (dim < loop->temp_dim) - flags = 3; - else - flags = 1; - /* Calculate values that will be constant within this loop. */ - gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); - } - gfc_start_block (pbody); -} - - -/* Generates the actual loop code for a scalarization loop. */ - -void -gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, - stmtblock_t * pbody) -{ - stmtblock_t block; - tree cond; - tree tmp; - tree loopbody; - tree exit_label; - tree stmt; - tree init; - tree incr; - - if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)) - == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) - && n == loop->dimen - 1) - { - /* We create an OMP_FOR construct for the outermost scalarized loop. */ - init = make_tree_vec (1); - cond = make_tree_vec (1); - incr = make_tree_vec (1); - - /* Cycle statement is implemented with a goto. Exit statement must not - be present for this loop. */ - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* Label for cycle statements (if needed). */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (pbody, tmp); - - stmt = make_node (OMP_FOR); - - TREE_TYPE (stmt) = void_type_node; - OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody); - - OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location, - OMP_CLAUSE_SCHEDULE); - OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt)) - = OMP_CLAUSE_SCHEDULE_STATIC; - if (ompws_flags & OMPWS_NOWAIT) - OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt)) - = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT); - - /* Initialize the loopvar. */ - TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n], - loop->from[n]); - OMP_FOR_INIT (stmt) = init; - /* The exit condition. */ - TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, - boolean_type_node, - loop->loopvar[n], loop->to[n]); - SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); - OMP_FOR_COND (stmt) = cond; - /* Increment the loopvar. */ - tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); - TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, loop->loopvar[n], tmp); - OMP_FOR_INCR (stmt) = incr; - - ompws_flags &= ~OMPWS_CURR_SINGLEUNIT; - gfc_add_expr_to_block (&loop->code[n], stmt); - } - else - { - bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) - && (loop->temp_ss == NULL); - - loopbody = gfc_finish_block (pbody); - - if (reverse_loop) - { - tmp = loop->from[n]; - loop->from[n] = loop->to[n]; - loop->to[n] = tmp; - } - - /* Initialize the loopvar. */ - if (loop->loopvar[n] != loop->from[n]) - gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); - - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Generate the loop body. */ - gfc_init_block (&block); - - /* The exit condition. */ - cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, - boolean_type_node, loop->loopvar[n], loop->to[n]); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - - /* The main body. */ - gfc_add_expr_to_block (&block, loopbody); - - /* Increment the loopvar. */ - tmp = fold_build2_loc (input_location, - reverse_loop ? MINUS_EXPR : PLUS_EXPR, - gfc_array_index_type, loop->loopvar[n], - gfc_index_one_node); - - gfc_add_modify (&block, loop->loopvar[n], tmp); - - /* Build the loop. */ - tmp = gfc_finish_block (&block); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&loop->code[n], tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&loop->code[n], tmp); - } - -} - - -/* Finishes and generates the loops for a scalarized expression. */ - -void -gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - gfc_ss *ss; - stmtblock_t *pblock; - tree tmp; - - pblock = body; - /* Generate the loops. */ - for (dim = 0; dim < loop->dimen; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - tmp = gfc_finish_block (pblock); - gfc_add_expr_to_block (&loop->pre, tmp); - - /* Clear all the used flags. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->parent == NULL) - ss->info->useflags = 0; -} - - -/* Finish the main body of a scalarized expression, and start the secondary - copying body. */ - -void -gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - stmtblock_t *pblock; - gfc_ss *ss; - - pblock = body; - /* We finish as many loops as are used by the temporary. */ - for (dim = 0; dim < loop->temp_dim - 1; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - /* We don't want to finish the outermost loop entirely. */ - n = loop->order[loop->temp_dim - 1]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - - /* Restore the initial offsets. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - - ss_info = ss->info; - - if ((ss_info->useflags & 2) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - ss_info->data.array.offset = ss_info->data.array.saved_offset; - } - - /* Restart all the inner loops we just finished. */ - for (dim = loop->temp_dim - 2; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); - - gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); - } - - /* Start a block for the secondary copying code. */ - gfc_start_block (body); -} - - -/* Precalculate (either lower or upper) bound of an array section. - BLOCK: Block in which the (pre)calculation code will go. - BOUNDS[DIM]: Where the bound value will be stored once evaluated. - VALUES[DIM]: Specified bound (NULL <=> unspecified). - DESC: Array descriptor from which the bound will be picked if unspecified - (either lower or upper bound according to LBOUND). */ - -static void -evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound) -{ - gfc_se se; - gfc_expr * input_val = values[dim]; - tree *output = &bounds[dim]; - - - if (input_val) - { - /* Specified section bound. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, input_val, gfc_array_index_type); - gfc_add_block_to_block (block, &se.pre); - *output = se.expr; - } - else - { - /* No specific bound specified so use the bound of the array. */ - *output = lbound ? gfc_conv_array_lbound (desc, dim) : - gfc_conv_array_ubound (desc, dim); - } - *output = gfc_evaluate_now (*output, block); -} - - -/* Calculate the lower bound of an array section. */ - -static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) -{ - gfc_expr *stride = NULL; - tree desc; - gfc_se se; - gfc_array_info *info; - gfc_array_ref *ar; - - gcc_assert (ss->info->type == GFC_SS_SECTION); - - info = &ss->info->data.array; - ar = &info->ref->u.ar; - - if (ar->dimen_type[dim] == DIMEN_VECTOR) - { - /* We use a zero-based index to access the vector. */ - info->start[dim] = gfc_index_zero_node; - info->end[dim] = NULL; - info->stride[dim] = gfc_index_one_node; - return; - } - - gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE - || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); - desc = info->descriptor; - stride = ar->stride[dim]; - - /* Calculate the start of the range. For vector subscripts this will - be the range of the vector. */ - evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true); - - /* Similarly calculate the end. Although this is not used in the - scalarizer, it is needed when checking bounds and where the end - is an expression with side-effects. */ - evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false); - - /* Calculate the stride. */ - if (stride == NULL) - info->stride[dim] = gfc_index_one_node; - else - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, stride, gfc_array_index_type); - gfc_add_block_to_block (&loop->pre, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre); - } -} - - -/* Calculates the range start and stride for a SS chain. Also gets the - descriptor and data pointer. The range of vector subscripts is the size - of the vector. Array bounds are also checked. */ - -void -gfc_conv_ss_startstride (gfc_loopinfo * loop) -{ - int n; - tree tmp; - gfc_ss *ss; - tree desc; - - loop->dimen = 0; - /* Determine the rank of the loop. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - switch (ss->info->type) - { - case GFC_SS_SECTION: - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - case GFC_SS_COMPONENT: - loop->dimen = ss->dimen; - goto done; - - /* As usual, lbound and ubound are exceptions!. */ - case GFC_SS_INTRINSIC: - switch (ss->info->expr->value.function.isym->id) - { - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_THIS_IMAGE: - loop->dimen = ss->dimen; - goto done; - - default: - break; - } - - default: - break; - } - } - - /* We should have determined the rank of the expression by now. If - not, that's bad news. */ - gcc_unreachable (); - -done: - /* Loop over all the SS in the chain. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - if (expr && expr->shape && !info->shape) - info->shape = expr->shape; - - switch (ss_info->type) - { - case GFC_SS_SECTION: - /* Get the descriptor for the array. If it is a cross loops array, - we got the descriptor already in the outermost loop. */ - if (ss->parent == NULL) - gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); - - for (n = 0; n < ss->dimen; n++) - gfc_conv_section_startstride (loop, ss, ss->dim[n]); - break; - - case GFC_SS_INTRINSIC: - switch (expr->value.function.isym->id) - { - /* Fall through to supply start and stride. */ - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - { - gfc_expr *arg; - - /* This is the variant without DIM=... */ - gcc_assert (expr->value.function.actual->next->expr == NULL); - - arg = expr->value.function.actual->expr; - if (arg->rank == -1) - { - gfc_se se; - tree rank, tmp; - - /* The rank (hence the return value's shape) is unknown, - we have to retrieve it. */ - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr (&se, arg); - /* This is a bare variable, so there is no preliminary - or cleanup code. */ - gcc_assert (se.pre.head == NULL_TREE - && se.post.head == NULL_TREE); - rank = gfc_conv_descriptor_rank (se.expr); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - rank), - gfc_index_one_node); - info->end[0] = gfc_evaluate_now (tmp, &loop->pre); - info->start[0] = gfc_index_zero_node; - info->stride[0] = gfc_index_one_node; - continue; - } - /* Otherwise fall through GFC_SS_FUNCTION. */ - } - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_THIS_IMAGE: - break; - - default: - continue; - } - - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - for (n = 0; n < ss->dimen; n++) - { - int dim = ss->dim[n]; - - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - break; - - default: - break; - } - } - - /* The rest is just runtime bound checking. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - stmtblock_t block; - tree lbound, ubound; - tree end; - tree size[GFC_MAX_DIMENSIONS]; - tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; - gfc_array_info *info; - char *msg; - int dim; - - gfc_start_block (&block); - - for (n = 0; n < loop->dimen; n++) - size[n] = NULL_TREE; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - stmtblock_t inner; - gfc_ss_info *ss_info; - gfc_expr *expr; - locus *expr_loc; - const char *expr_name; - - ss_info = ss->info; - if (ss_info->type != GFC_SS_SECTION) - continue; - - /* Catch allocatable lhs in f2003. */ - if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs) - continue; - - expr = ss_info->expr; - expr_loc = &expr->where; - expr_name = expr->symtree->name; - - gfc_start_block (&inner); - - /* TODO: range checking for mapped dimensions. */ - info = &ss_info->data.array; - - /* This code only checks ranges. Elemental and vector - dimensions are checked later. */ - for (n = 0; n < loop->dimen; n++) - { - bool check_upper; - - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - continue; - - if (dim == info->ref->u.ar.dimen - 1 - && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) - check_upper = false; - else - check_upper = true; - - /* Zero stride is not allowed. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - info->stride[dim], gfc_index_zero_node); - asprintf (&msg, "Zero stride is not allowed, for dimension %d " - "of array '%s'", dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg); - free (msg); - - desc = info->descriptor; - - /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ - lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[dim]; - if (check_upper) - ubound = gfc_conv_array_ubound (desc, dim); - else - ubound = NULL; - - /* non_zerosized is true when the selected range is not - empty. */ - stride_pos = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, info->stride[dim], - gfc_index_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, - info->start[dim], end); - stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, stride_pos, tmp); - - stride_neg = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, - info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - info->start[dim], end); - stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, - stride_neg, tmp); - non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, - stride_pos, stride_neg); - - /* Check the start of the range against the lower and upper - bounds of the array, if the range is not empty. - If upper bound is present, include both bounds in the - error message. */ - if (check_upper) - { - tmp = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, - non_zerosized, tmp); - tmp2 = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, - info->start[dim], ubound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, - non_zerosized, tmp2); - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - free (msg); - } - else - { - tmp = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp); - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Compute the last element of the range, which is not - necessarily "end" (think 0:5:3, which doesn't contain 5) - and check it against both lower and upper bounds. */ - - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, tmp); - tmp2 = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, lbound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp2); - if (check_upper) - { - tmp3 = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, tmp, ubound); - tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp3); - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - else - { - asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Check the section sizes match. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, tmp); - tmp = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, tmp, - build_int_cst (gfc_array_index_type, 0)); - /* We remember the size of the first section, and check all the - others against this. */ - if (size[n]) - { - tmp3 = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, size[n]); - asprintf (&msg, "Array bound mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", - dim + 1, expr_name); - - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, size[n])); - - free (msg); - } - else - size[n] = gfc_evaluate_now (tmp, &inner); - } - - tmp = gfc_finish_block (&inner); - - /* For optional arguments, only check bounds if the argument is - present. */ - if (expr->symtree->n.sym->attr.optional - || expr->symtree->n.sym->attr.not_always_present) - tmp = build3_v (COND_EXPR, - gfc_conv_expr_present (expr->symtree->n.sym), - tmp, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - - } - - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&loop->pre, tmp); - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_conv_ss_startstride (loop); -} - -/* Return true if both symbols could refer to the same data object. Does - not take account of aliasing due to equivalence statements. */ - -static int -symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, - bool lsym_target, bool rsym_pointer, bool rsym_target) -{ - /* Aliasing isn't possible if the symbols have different base types. */ - if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) - return 0; - - /* Pointers can point to other pointers and target objects. */ - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - return 1; - - /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 - and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already - checked above. */ - if (lsym_target && rsym_target - && ((lsym->attr.dummy && !lsym->attr.contiguous - && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) - || (rsym->attr.dummy && !rsym->attr.contiguous - && (!rsym->attr.dimension - || rsym->as->type == AS_ASSUMED_SHAPE)))) - return 1; - - return 0; -} - - -/* Return true if the two SS could be aliased, i.e. both point to the same data - object. */ -/* TODO: resolve aliases based on frontend expressions. */ - -static int -gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) -{ - gfc_ref *lref; - gfc_ref *rref; - gfc_expr *lexpr, *rexpr; - gfc_symbol *lsym; - gfc_symbol *rsym; - bool lsym_pointer, lsym_target, rsym_pointer, rsym_target; - - lexpr = lss->info->expr; - rexpr = rss->info->expr; - - lsym = lexpr->symtree->n.sym; - rsym = rexpr->symtree->n.sym; - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - rsym_pointer = rsym->attr.pointer; - rsym_target = rsym->attr.target; - - if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS - && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS) - return 0; - - /* For derived types we must check all the component types. We can ignore - array references as these will have the same base type as the previous - component ref. */ - for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) - { - if (lref->type != REF_COMPONENT) - continue; - - lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer; - lsym_target = lsym_target || lref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rsym->ts)) - return 1; - } - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; - rref = rref->next) - { - if (rref->type != REF_COMPONENT) - continue; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.sym->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.sym->ts, - &rref->u.c.component->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.component->ts)) - return 1; - } - } - } - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) - { - if (rref->type != REF_COMPONENT) - break; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (rref->u.c.sym, lsym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts)) - return 1; - } - } - - return 0; -} - - -/* Resolve array data dependencies. Creates a temporary if required. */ -/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to - dependency.c. */ - -void -gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, - gfc_ss * rss) -{ - gfc_ss *ss; - gfc_ref *lref; - gfc_ref *rref; - gfc_expr *dest_expr; - gfc_expr *ss_expr; - int nDepend = 0; - int i, j; - - loop->temp_ss = NULL; - dest_expr = dest->info->expr; - - for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) - { - if (ss->info->type != GFC_SS_SECTION) - continue; - - ss_expr = ss->info->expr; - - if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym) - { - if (gfc_could_be_alias (dest, ss) - || gfc_are_equivalenced_arrays (dest_expr, ss_expr)) - { - nDepend = 1; - break; - } - } - else - { - lref = dest_expr->ref; - rref = ss_expr->ref; - - nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); - - if (nDepend == 1) - break; - - for (i = 0; i < dest->dimen; i++) - for (j = 0; j < ss->dimen; j++) - if (i != j - && dest->dim[i] == ss->dim[j]) - { - /* If we don't access array elements in the same order, - there is a dependency. */ - nDepend = 1; - goto temporary; - } -#if 0 - /* TODO : loop shifting. */ - if (nDepend == 1) - { - /* Mark the dimensions for LOOP SHIFTING */ - for (n = 0; n < loop->dimen; n++) - { - int dim = dest->data.info.dim[n]; - - if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - depends[n] = 2; - else if (! gfc_is_same_range (&lref->u.ar, - &rref->u.ar, dim, 0)) - depends[n] = 1; - } - - /* Put all the dimensions with dependencies in the - innermost loops. */ - dim = 0; - for (n = 0; n < loop->dimen; n++) - { - gcc_assert (loop->order[n] == n); - if (depends[n]) - loop->order[dim++] = n; - } - for (n = 0; n < loop->dimen; n++) - { - if (! depends[n]) - loop->order[dim++] = n; - } - - gcc_assert (dim == loop->dimen); - break; - } -#endif - } - } - -temporary: - - if (nDepend == 1) - { - tree base_type = gfc_typenode_for_spec (&dest_expr->ts); - if (GFC_ARRAY_TYPE_P (base_type) - || GFC_DESCRIPTOR_TYPE_P (base_type)) - base_type = gfc_get_element_type (base_type); - loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length, - loop->dimen); - gfc_add_ss_to_loop (loop, loop->temp_ss); - } - else - loop->temp_ss = NULL; -} - - -/* Browse through each array's information from the scalarizer and set the loop - bounds according to the "best" one (per dimension), i.e. the one which - provides the most information (constant bounds, shape, etc.). */ - -static void -set_loop_bounds (gfc_loopinfo *loop) -{ - int n, dim, spec_dim; - gfc_array_info *info; - gfc_array_info *specinfo; - gfc_ss *ss; - tree tmp; - gfc_ss **loopspec; - bool dynamic[GFC_MAX_DIMENSIONS]; - mpz_t *cshape; - mpz_t i; - bool nonoptional_arr; - - loopspec = loop->specloop; - - mpz_init (i); - for (n = 0; n < loop->dimen; n++) - { - loopspec[n] = NULL; - dynamic[n] = false; - - /* If there are both optional and nonoptional array arguments, scalarize - over the nonoptional; otherwise, it does not matter as then all - (optional) arrays have to be present per F2008, 125.2.12p3(6). */ - - nonoptional_arr = false; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP - && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) - nonoptional_arr = true; - - /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type == GFC_SS_SCALAR - || ss_type == GFC_SS_TEMP - || ss_type == GFC_SS_REFERENCE - || (ss->info->can_be_null_ref && nonoptional_arr)) - continue; - - info = &ss->info->data.array; - dim = ss->dim[n]; - - if (loopspec[n] != NULL) - { - specinfo = &loopspec[n]->info->data.array; - spec_dim = loopspec[n]->dim[n]; - } - else - { - /* Silence uninitialized warnings. */ - specinfo = NULL; - spec_dim = 0; - } - - if (info->shape) - { - gcc_assert (info->shape[dim]); - /* The frontend has worked out the size for us. */ - if (!loopspec[n] - || !specinfo->shape - || !integer_zerop (specinfo->start[spec_dim])) - /* Prefer zero-based descriptors if possible. */ - loopspec[n] = ss; - continue; - } - - if (ss_type == GFC_SS_CONSTRUCTOR) - { - gfc_constructor_base base; - /* An unknown size constructor will always be rank one. - Higher rank constructors will either have known shape, - or still be wrapped in a call to reshape. */ - gcc_assert (loop->dimen == 1); - - /* Always prefer to use the constructor bounds if the size - can be determined at compile time. Prefer not to otherwise, - since the general case involves realloc, and it's better to - avoid that overhead if possible. */ - base = ss->info->expr->value.constructor; - dynamic[n] = gfc_get_array_constructor_size (&i, base); - if (!dynamic[n] || !loopspec[n]) - loopspec[n] = ss; - continue; - } - - /* Avoid using an allocatable lhs in an assignment, since - there might be a reallocation coming. */ - if (loopspec[n] && ss->is_alloc_lhs) - continue; - - if (!loopspec[n]) - loopspec[n] = ss; - /* Criteria for choosing a loop specifier (most important first): - doesn't need realloc - stride of one - known stride - known lower bound - known upper bound - */ - else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) - loopspec[n] = ss; - else if (integer_onep (info->stride[dim]) - && !integer_onep (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[dim]) - && !INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[dim]) - && !INTEGER_CST_P (specinfo->start[spec_dim]) - && integer_onep (info->stride[dim]) - == integer_onep (specinfo->stride[spec_dim]) - && INTEGER_CST_P (info->stride[dim]) - == INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - /* We don't work out the upper bound. - else if (INTEGER_CST_P (info->finish[n]) - && ! INTEGER_CST_P (specinfo->finish[n])) - loopspec[n] = ss; */ - } - - /* We should have found the scalarization loop specifier. If not, - that's bad news. */ - gcc_assert (loopspec[n]); - - info = &loopspec[n]->info->data.array; - dim = loopspec[n]->dim[n]; - - /* Set the extents of this range. */ - cshape = info->shape; - if (cshape && INTEGER_CST_P (info->start[dim]) - && INTEGER_CST_P (info->stride[dim])) - { - loop->from[n] = info->start[dim]; - mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); - mpz_sub_ui (i, i, 1); - /* To = from + (size - 1) * stride. */ - tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop->from[n], tmp); - } - else - { - loop->from[n] = info->start[dim]; - switch (loopspec[n]->info->type) - { - case GFC_SS_CONSTRUCTOR: - /* The upper bound is calculated when we expand the - constructor. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_SECTION: - /* Use the end expression if it exists and is not constant, - so that it is only evaluated once. */ - loop->to[n] = info->end[dim]; - break; - - case GFC_SS_FUNCTION: - /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_INTRINSIC: - { - gfc_expr *expr = loopspec[n]->info->expr; - - /* The {l,u}bound of an assumed rank. */ - gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND - || expr->value.function.isym->id == GFC_ISYM_UBOUND) - && expr->value.function.actual->next->expr == NULL - && expr->value.function.actual->expr->rank == -1); - - loop->to[n] = info->end[dim]; - break; - } - - default: - gcc_unreachable (); - } - } - - /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[dim])) - info->delta[dim] = gfc_index_zero_node; - else - { - /* Set the delta for this section. */ - info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); - /* Number of iterations is (end - start + step) / step. - with start = 0, this simplifies to - last = end / step; - for (i = 0; i<=last; i++){...}; */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, loop->to[n], - loop->from[n]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, info->stride[dim]); - tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - tmp, build_int_cst (gfc_array_index_type, -1)); - loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); - /* Make the loop variable start at 0. */ - loop->from[n] = gfc_index_zero_node; - } - } - mpz_clear (i); - - for (loop = loop->nested; loop; loop = loop->next) - set_loop_bounds (loop); -} - - -/* Initialize the scalarization loop. Creates the loop variables. Determines - the range of the loop variables. Creates a temporary if required. - Also generates code for scalar expressions which have been - moved outside the loop. */ - -void -gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) -{ - gfc_ss *tmp_ss; - tree tmp; - - set_loop_bounds (loop); - - /* Add all the scalar code that can be taken out of the loops. - This may include calculating the loop bounds, so do it before - allocating the temporary. */ - gfc_add_loop_ss_code (loop, loop->ss, false, where); - - tmp_ss = loop->temp_ss; - /* If we want a temporary then create it. */ - if (tmp_ss != NULL) - { - gfc_ss_info *tmp_ss_info; - - tmp_ss_info = tmp_ss->info; - gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); - gcc_assert (loop->parent == NULL); - - /* Make absolutely sure that this is a complete type. */ - if (tmp_ss_info->string_length) - tmp_ss_info->data.temp.type - = gfc_get_character_type_len_for_eltype - (TREE_TYPE (tmp_ss_info->data.temp.type), - tmp_ss_info->string_length); - - tmp = tmp_ss_info->data.temp.type; - memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); - tmp_ss_info->type = GFC_SS_SECTION; - - gcc_assert (tmp_ss->dimen != 0); - - gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, - NULL_TREE, false, true, false, where); - } - - /* For array parameters we don't have loop variables, so don't calculate the - translations. */ - if (!loop->array_parameter) - gfc_set_delta (loop); -} - - -/* Calculates how to transform from loop variables to array indices for each - array: once loop bounds are chosen, sets the difference (DELTA field) between - loop bounds and array reference bounds, for each array info. */ - -void -gfc_set_delta (gfc_loopinfo *loop) -{ - gfc_ss *ss, **loopspec; - gfc_array_info *info; - tree tmp; - int n, dim; - - loopspec = loop->specloop; - - /* Calculate the translation from loop variables to array indices. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) - continue; - - info = &ss->info->data.array; - - for (n = 0; n < ss->dimen; n++) - { - /* If we are specifying the range the delta is already set. */ - if (loopspec[n] != ss) - { - dim = ss->dim[n]; - - /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ - tmp = loop->from[n]; - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, info->stride[dim]); - - /* Then subtract this from our starting value. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - info->start[dim], tmp); - - info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre); - } - } - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_set_delta (loop); -} - - -/* Calculate the size of a given array dimension from the bounds. This - is simply (ubound - lbound + 1) if this expression is positive - or 0 if it is negative (pick either one if it is zero). Optionally - (if or_expr is present) OR the (expression != 0) condition to it. */ - -tree -gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) -{ - tree res; - tree cond; - - /* Calculate (ubound - lbound + 1). */ - res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, - gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res, - gfc_index_zero_node); - res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - gfc_index_zero_node, res); - - /* Build OR expression. */ - if (or_expr) - *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, *or_expr, cond); - - return res; -} - - -/* For an array descriptor, get the total number of elements. This is just - the product of the extents along from_dim to to_dim. */ - -static tree -gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) -{ - tree res; - int dim; - - res = gfc_index_one_node; - - for (dim = from_dim; dim < to_dim; ++dim) - { - tree lbound; - tree ubound; - tree extent; - - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - res, extent); - } - - return res; -} - - -/* Full size of an array. */ - -tree -gfc_conv_descriptor_size (tree desc, int rank) -{ - return gfc_conv_descriptor_size_1 (desc, 0, rank); -} - - -/* Size of a coarray for all dimensions but the last. */ - -tree -gfc_conv_descriptor_cosize (tree desc, int rank, int corank) -{ - return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1); -} - - -/* Fills in an array descriptor, and returns the size of the array. - The size will be a simple_val, ie a variable or a constant. Also - calculates the offset of the base. The pointer argument overflow, - which should be of integer type, will increase in value if overflow - occurs during the size calculation. Returns the size of the array. - { - stride = 1; - offset = 0; - for (n = 0; n < rank; n++) - { - a.lbound[n] = specified_lower_bound; - offset = offset + a.lbond[n] * stride; - size = 1 - lbound; - a.ubound[n] = specified_upper_bound; - a.stride[n] = stride; - size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound - overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); - stride = stride * size; - } - for (n = rank; n < rank+corank; n++) - (Set lcobound/ucobound as above.) - element_size = sizeof (array element); - if (!rank) - return element_size - stride = (size_t) stride; - overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); - stride = stride * element_size; - return (stride); - } */ -/*GCC ARRAYS*/ - -static tree -gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, - gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, - stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3) -{ - tree type; - tree tmp; - tree size; - tree offset; - tree stride; - tree element_size; - tree or_expr; - tree thencase; - tree elsecase; - tree cond; - tree var; - stmtblock_t thenblock; - stmtblock_t elseblock; - gfc_expr *ubound; - gfc_se se; - int n; - - type = TREE_TYPE (descriptor); - - stride = gfc_index_one_node; - offset = gfc_index_zero_node; - - /* Set the dtype. */ - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); - - or_expr = boolean_false_node; - - for (n = 0; n < rank; n++) - { - tree conv_lbound; - tree conv_ubound; - - /* We have 3 possibilities for determining the size of the array: - lower == NULL => lbound = 1, ubound = upper[n] - upper[n] = NULL => lbound = 1, ubound = lower[n] - upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (lower == NULL) - se.expr = gfc_index_one_node; - else - { - gcc_assert (lower[n]); - if (ubound) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_lbound = se.expr; - - /* Work out the offset for this component. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - se.expr, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* Set upper bound. */ - gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_ubound = se.expr; - - /* Store the stride. */ - gfc_conv_descriptor_stride_set (descriptor_block, descriptor, - gfc_rank_cst[n], stride); - - /* Calculate size and check whether extent is negative. */ - size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); - size = gfc_evaluate_now (size, pblock); - - /* Check whether multiplying the stride by the number of - elements in this dimension would overflow. We must also check - whether the current dimension has zero size in order to avoid - division by zero. - */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - TYPE_MAX_VALUE (gfc_array_index_type)), - size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, stride)); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, size, - gfc_index_zero_node)); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - /* Multiply the stride by the number of elements in this dimension. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, size); - stride = gfc_evaluate_now (stride, pblock); - } - - for (n = rank; n < rank + corank; n++) - { - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (lower == NULL || lower[n] == NULL) - { - gcc_assert (n == rank + corank - 1); - se.expr = gfc_index_one_node; - } - else - { - if (ubound || n == rank + corank - 1) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - - if (n < rank + corank - 1) - { - gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - } - } - - /* The stride is the number of elements in the array, so multiply by the - size of an element to get the total size. Obviously, if there is a - SOURCE expression (expr3) we must use its element size. */ - if (expr3_elem_size != NULL_TREE) - tmp = expr3_elem_size; - else if (expr3 != NULL) - { - if (expr3->ts.type == BT_CLASS) - { - gfc_se se_sz; - gfc_expr *sz = gfc_copy_expr (expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - tmp = se_sz.expr; - } - else - { - tmp = gfc_typenode_for_spec (&expr3->ts); - tmp = TYPE_SIZE_UNIT (tmp); - } - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - - /* Convert to size_t. */ - element_size = fold_convert (size_type_node, tmp); - - if (rank == 0) - return element_size; - - *nelems = gfc_evaluate_now (stride, pblock); - stride = fold_convert (size_type_node, stride); - - /* First check for overflow. Since an array of type character can - have zero element_size, we must check for that before - dividing. */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - size_type_node, - TYPE_MAX_VALUE (size_type_node), element_size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, stride)); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, element_size, - build_int_cst (size_type_node, 0))); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - stride, element_size); - - if (poffset != NULL) - { - offset = gfc_evaluate_now (offset, pblock); - *poffset = offset; - } - - if (integer_zerop (or_expr)) - return size; - if (integer_onep (or_expr)) - return build_int_cst (size_type_node, 0); - - var = gfc_create_var (TREE_TYPE (size), "size"); - gfc_start_block (&thenblock); - gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0)); - thencase = gfc_finish_block (&thenblock); - - gfc_start_block (&elseblock); - gfc_add_modify (&elseblock, var, size); - elsecase = gfc_finish_block (&elseblock); - - tmp = gfc_evaluate_now (or_expr, pblock); - tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); - gfc_add_expr_to_block (pblock, tmp); - - return var; -} - - -/* Initializes the descriptor and generates a call to _gfor_allocate. Does - the work for an ALLOCATE statement. */ -/*GCC ARRAYS*/ - -bool -gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3) -{ - tree tmp; - tree pointer; - tree offset = NULL_TREE; - tree token = NULL_TREE; - tree size; - tree msg; - tree error = NULL_TREE; - tree overflow; /* Boolean storing whether size calculation overflows. */ - tree var_overflow = NULL_TREE; - tree cond; - tree set_descriptor; - stmtblock_t set_descriptor_block; - stmtblock_t elseblock; - gfc_expr **lower; - gfc_expr **upper; - gfc_ref *ref, *prev_ref = NULL; - bool allocatable, coarray, dimension; - - ref = expr->ref; - - /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) - { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT - || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); - prev_ref = ref; - ref = ref->next; - } - - if (ref == NULL || ref->type != REF_ARRAY) - return false; - - if (!prev_ref) - { - allocatable = expr->symtree->n.sym->attr.allocatable; - coarray = expr->symtree->n.sym->attr.codimension; - dimension = expr->symtree->n.sym->attr.dimension; - } - else - { - allocatable = prev_ref->u.c.component->attr.allocatable; - coarray = prev_ref->u.c.component->attr.codimension; - dimension = prev_ref->u.c.component->attr.dimension; - } - - if (!dimension) - gcc_assert (coarray); - - /* Figure out the size of the array. */ - switch (ref->u.ar.type) - { - case AR_ELEMENT: - if (!coarray) - { - lower = NULL; - upper = ref->u.ar.start; - break; - } - /* Fall through. */ - - case AR_SECTION: - lower = ref->u.ar.start; - upper = ref->u.ar.end; - break; - - case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT); - - lower = ref->u.ar.as->lower; - upper = ref->u.ar.as->upper; - break; - - default: - gcc_unreachable (); - break; - } - - overflow = integer_zero_node; - - gfc_init_block (&set_descriptor_block); - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, - ref->u.ar.as->corank, &offset, lower, upper, - &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3); - - if (dimension) - { - - var_overflow = gfc_create_var (integer_type_node, "overflow"); - gfc_add_modify (&se->pre, var_overflow, overflow); - - /* Generate the block of code handling overflow. */ - msg = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const - ("Integer overflow when calculating the amount of " - "memory to allocate")); - error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error, - 1, msg); - } - - if (status != NULL_TREE) - { - tree status_type = TREE_TYPE (status); - stmtblock_t set_status_block; - - gfc_start_block (&set_status_block); - gfc_add_modify (&set_status_block, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); - error = gfc_finish_block (&set_status_block); - } - - gfc_start_block (&elseblock); - - /* Allocate memory to store the data. */ - if (POINTER_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - pointer = gfc_conv_descriptor_data_get (se->expr); - STRIP_NOPS (pointer); - - if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB) - token = gfc_build_addr_expr (NULL_TREE, - gfc_conv_descriptor_token (se->expr)); - - /* The allocatable variant takes the old pointer as first argument. */ - if (allocatable) - gfc_allocate_allocatable (&elseblock, pointer, size, token, - status, errmsg, errlen, label_finish, expr); - else - gfc_allocate_using_malloc (&elseblock, pointer, size, status); - - if (dimension) - { - cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, var_overflow, integer_zero_node)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - error, gfc_finish_block (&elseblock)); - } - else - tmp = gfc_finish_block (&elseblock); - - gfc_add_expr_to_block (&se->pre, tmp); - - if (expr->ts.type == BT_CLASS) - { - tmp = build_int_cst (unsigned_char_type_node, 0); - /* With class objects, it is best to play safe and null the - memory because we cannot know if dynamic types have allocatable - components or not. */ - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMSET), - 3, pointer, tmp, size); - gfc_add_expr_to_block (&se->pre, tmp); - } - - /* Update the array descriptors. */ - if (dimension) - gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); - - set_descriptor = gfc_finish_block (&set_descriptor_block); - if (status != NULL_TREE) - { - cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - gfc_add_expr_to_block (&se->pre, - fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_likely (cond), set_descriptor, - build_empty_stmt (input_location))); - } - else - gfc_add_expr_to_block (&se->pre, set_descriptor); - - if ((expr->ts.type == BT_DERIVED) - && expr->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr, - ref->u.ar.as->rank); - gfc_add_expr_to_block (&se->pre, tmp); - } - - return true; -} - - -/* Deallocate an array variable. Also used when an allocated variable goes - out of scope. */ -/*GCC ARRAYS*/ - -tree -gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr) -{ - tree var; - tree tmp; - stmtblock_t block; - bool coarray = gfc_is_coarray (expr); - - gfc_start_block (&block); - - /* Get a pointer to the data. */ - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Parameter is the address of the data component. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, - errlen, label_finish, false, expr, coarray); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer; only for coarrays an error can occur and then - the allocation status may not be changed. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB) - { - tree cond; - tree stat = build_fold_indirect_ref_loc (input_location, pstat); - - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Create an array constructor from an initialization expression. - We assume the frontend already did any expansions and conversions. */ - -tree -gfc_conv_array_initializer (tree type, gfc_expr * expr) -{ - gfc_constructor *c; - tree tmp; - gfc_se se; - HOST_WIDE_INT hi; - unsigned HOST_WIDE_INT lo; - tree index, range; - vec<constructor_elt, va_gc> *v = NULL; - - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->attr.flavor == FL_PARAMETER - && expr->symtree->n.sym->value) - expr = expr->symtree->n.sym->value; - - switch (expr->expr_type) - { - case EXPR_CONSTANT: - case EXPR_STRUCTURE: - /* A single scalar or derived type value. Create an array with all - elements equal to that value. */ - gfc_init_se (&se, NULL); - - if (expr->expr_type == EXPR_CONSTANT) - gfc_conv_constant (&se, expr); - else - gfc_conv_structure (&se, expr, 1); - - tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - gcc_assert (tmp && INTEGER_CST_P (tmp)); - hi = TREE_INT_CST_HIGH (tmp); - lo = TREE_INT_CST_LOW (tmp); - lo++; - if (lo == 0) - hi++; - /* This will probably eat buckets of memory for large arrays. */ - while (hi != 0 || lo != 0) - { - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr); - if (lo == 0) - hi--; - lo--; - } - break; - - case EXPR_ARRAY: - /* Create a vector of all the elements. */ - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c)) - { - if (c->iterator) - { - /* Problems occur when we get something like - integer :: a(lots) = (/(i, i=1, lots)/) */ - gfc_fatal_error ("The number of elements in the array constructor " - "at %L requires an increase of the allowed %d " - "upper limit. See -fmax-array-constructor " - "option", &expr->where, - gfc_option.flag_max_array_constructor); - return NULL_TREE; - } - if (mpz_cmp_si (c->offset, 0) != 0) - index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - else - index = NULL_TREE; - - if (mpz_cmp_si (c->repeat, 1) > 0) - { - tree tmp1, tmp2; - mpz_t maxval; - - mpz_init (maxval); - mpz_add (maxval, c->offset, c->repeat); - mpz_sub_ui (maxval, maxval, 1); - tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->offset, 0) != 0) - { - mpz_add_ui (maxval, c->offset, 1); - tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - } - else - tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - - range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); - mpz_clear (maxval); - } - else - range = NULL; - - gfc_init_se (&se, NULL); - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - gfc_conv_constant (&se, c->expr); - break; - - case EXPR_STRUCTURE: - gfc_conv_structure (&se, c->expr, 1); - break; - - default: - /* Catch those occasional beasts that do not simplify - for one reason or another, assuming that if they are - standard defying the frontend will catch them. */ - gfc_conv_expr (&se, c->expr); - break; - } - - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } - } - break; - - case EXPR_NULL: - return gfc_build_null_descriptor (type); - - default: - gcc_unreachable (); - } - - /* Create a constructor from the list of elements. */ - tmp = build_constructor (type, v); - TREE_CONSTANT (tmp) = 1; - return tmp; -} - - -/* Generate code to evaluate non-constant coarray cobounds. */ - -void -gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, - const gfc_symbol *sym) -{ - int dim; - tree ubound; - tree lbound; - gfc_se se; - gfc_array_spec *as; - - as = sym->as; - - for (dim = as->rank; dim < as->rank + as->corank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - } -} - - -/* Generate code to evaluate non-constant array bounds. Sets *poffset and - returns the size (in elements) of the array. */ - -static tree -gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, - stmtblock_t * pblock) -{ - gfc_array_spec *as; - tree size; - tree stride; - tree offset; - tree ubound; - tree lbound; - tree tmp; - gfc_se se; - - int dim; - - as = sym->as; - - size = gfc_index_one_node; - offset = gfc_index_zero_node; - for (dim = 0; dim < as->rank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, size); - offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (dim + 1 < as->rank) - stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); - else - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - if (stride) - gfc_add_modify (pblock, stride, tmp); - else - stride = gfc_evaluate_now (tmp, pblock); - - /* Make sure that negative size arrays are translated - to being zero size. */ - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, tmp, - stride, gfc_index_zero_node); - gfc_add_modify (pblock, stride, tmp); - } - - size = stride; - } - - gfc_trans_array_cobounds (type, pblock, sym); - gfc_trans_vla_type_sizes (sym, pblock); - - *poffset = offset; - return size; -} - - -/* Generate code to initialize/allocate an array variable. */ - -void -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, - gfc_wrapped_block * block) -{ - stmtblock_t init; - tree type; - tree tmp = NULL_TREE; - tree size; - tree offset; - tree space; - tree inittree; - bool onstack; - - gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); - - /* Do nothing for USEd variables. */ - if (sym->attr.use_assoc) - return; - - type = TREE_TYPE (decl); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - onstack = TREE_CODE (type) != POINTER_TYPE; - - gfc_init_block (&init); - - /* Evaluate character string length. */ - if (sym->ts.type == BT_CHARACTER - && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - gfc_trans_vla_type_sizes (sym, &init); - - /* Emit a DECL_EXPR for this variable, which will cause the - gimplifier to allocate storage, and all that good stuff. */ - tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&init, tmp); - } - - if (onstack) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - type = TREE_TYPE (type); - - gcc_assert (!sym->attr.use_assoc); - gcc_assert (!TREE_STATIC (decl)); - gcc_assert (!sym->module); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - size = gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Don't actually allocate space for Cray Pointees. */ - if (sym->attr.cray_pointee) - { - if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - if (gfc_option.flag_stack_arrays) - { - gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); - space = build_decl (sym->declared_at.lb->location, - VAR_DECL, create_tmp_var_name ("A"), - TREE_TYPE (TREE_TYPE (decl))); - gfc_trans_vla_type_sizes (sym, &init); - } - else - { - /* The size is the number of elements in the array, so multiply by the - size of an element to get the total size. */ - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, fold_convert (gfc_array_index_type, tmp)); - - /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); - gfc_add_modify (&init, decl, tmp); - - /* Free the temporary. */ - tmp = gfc_call_free (convert (pvoid_type_node, decl)); - space = NULL_TREE; - } - - /* Set offset of the array. */ - if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Automatic arrays should not have initializers. */ - gcc_assert (!sym->value); - - inittree = gfc_finish_block (&init); - - if (space) - { - tree addr; - pushdecl (space); - - /* Don't create new scope, emit the DECL_EXPR in exactly the scope - where also space is located. */ - gfc_init_block (&init); - tmp = fold_build1_loc (input_location, DECL_EXPR, - TREE_TYPE (space), space); - gfc_add_expr_to_block (&init, tmp); - addr = fold_build1_loc (sym->declared_at.lb->location, - ADDR_EXPR, TREE_TYPE (decl), space); - gfc_add_modify (&init, decl, addr); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - tmp = NULL_TREE; - } - gfc_add_init_cleanup (block, inittree, tmp); -} - - -/* Generate entry and exit code for g77 calling convention arrays. */ - -void -gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree parm; - tree type; - locus loc; - tree offset; - tree tmp; - tree stmt; - stmtblock_t init; - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - parm = sym->backend_decl; - type = TREE_TYPE (parm); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Set the offset. */ - if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Set the pointer itself if we aren't using the parameter directly. */ - if (TREE_CODE (parm) != PARM_DECL) - { - tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); - gfc_add_modify (&init, parm, tmp); - } - stmt = gfc_finish_block (&init); - - gfc_restore_backend_locus (&loc); - - /* Add the initialization code to the start of the function. */ - - if (sym->attr.optional || sym->attr.not_always_present) - { - tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); - } - - gfc_add_init_cleanup (block, stmt, NULL_TREE); -} - - -/* Modify the descriptor of an array parameter so that it has the - correct lower bound. Also move the upper bound accordingly. - If the array is not packed, it will be copied into a temporary. - For each dimension we set the new lower and upper bounds. Then we copy the - stride and calculate the offset for this dimension. We also work out - what the stride of a packed array would be, and see it the two match. - If the array need repacking, we set the stride to the values we just - calculated, recalculate the offset and copy the array data. - Code is also added to copy the data back at the end of the function. - */ - -void -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, - gfc_wrapped_block * block) -{ - tree size; - tree type; - tree offset; - locus loc; - stmtblock_t init; - tree stmtInit, stmtCleanup; - tree lbound; - tree ubound; - tree dubound; - tree dlbound; - tree dumdesc; - tree tmp; - tree stride, stride2; - tree stmt_packed; - tree stmt_unpacked; - tree partial; - gfc_se se; - int n; - int checkparm; - int no_repack; - bool optional_arg; - - /* Do nothing for pointer and allocatable arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) - return; - - if (sym->attr.dummy && gfc_is_nodesc_array (sym)) - { - gfc_trans_g77_array (sym, block); - return; - } - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - type = TREE_TYPE (tmpdesc); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - checkparm = (sym->as->type == AS_EXPLICIT - && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); - - no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); - - if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) - { - /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ - partial = gfc_create_var (boolean_type_node, "partial"); - TREE_USED (partial) = 1; - tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, - gfc_index_one_node); - gfc_add_modify (&init, partial, tmp); - } - else - partial = NULL_TREE; - - /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive - here, however I think it does the right thing. */ - if (no_repack) - { - /* Set the first stride. */ - stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &init); - - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node, stride); - stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&init, stride, tmp); - - /* Allow the user to disable array repacking. */ - stmt_unpacked = NULL_TREE; - } - else - { - gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); - /* A library call to repack the array if necessary. */ - tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - stmt_unpacked = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, tmp); - - stride = gfc_index_one_node; - - if (gfc_option.warn_array_temp) - gfc_warning ("Creating array temporary at %L", &loc); - } - - /* This is for the case where the array data is used directly without - calling the repack function. */ - if (no_repack || partial != NULL_TREE) - stmt_packed = gfc_conv_descriptor_data_get (dumdesc); - else - stmt_packed = NULL_TREE; - - /* Assign the data pointer. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - { - /* Don't repack unknown shape arrays when the first stride is 1. */ - tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), - partial, stmt_packed, stmt_unpacked); - } - else - tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); - - offset = gfc_index_zero_node; - size = gfc_index_one_node; - - /* Evaluate the bounds of the array. */ - for (n = 0; n < sym->as->rank; n++) - { - if (checkparm || !sym->as->upper[n]) - { - /* Get the bounds of the actual parameter. */ - dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); - dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); - } - else - { - dubound = NULL_TREE; - dlbound = NULL_TREE; - } - - lbound = GFC_TYPE_ARRAY_LBOUND (type, n); - if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, lbound, se.expr); - } - - ubound = GFC_TYPE_ARRAY_UBOUND (type, n); - /* Set the desired upper bound. */ - if (sym->as->upper[n]) - { - /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, ubound, se.expr); - } - - /* Check the sizes match. */ - if (checkparm) - { - /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ - char * msg; - tree temp; - - temp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - temp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, temp); - stride2 = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, - dlbound); - stride2 = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, stride2); - tmp = fold_build2_loc (input_location, NE_EXPR, - gfc_array_index_type, temp, stride2); - asprintf (&msg, "Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); - - gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, - fold_convert (long_integer_type_node, temp), - fold_convert (long_integer_type_node, stride2)); - - free (msg); - } - } - else - { - /* For assumed shape arrays move the upper bound by the same amount - as the lower bound. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, dlbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, lbound); - gfc_add_modify (&init, ubound, tmp); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (n + 1 < sym->as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - - if (no_repack || partial != NULL_TREE) - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - stmt_packed = size; - } - - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, partial, - stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, stride, tmp); - } - } - else - { - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (stride && !INTEGER_CST_P (stride)) - { - /* Calculate size = stride * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&init, stride, tmp); - } - } - } - - gfc_trans_array_cobounds (type, &init, sym); - - /* Set the offset. */ - if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_trans_vla_type_sizes (sym, &init); - - stmtInit = gfc_finish_block (&init); - - /* Only do the entry/initialization code if the arg is present. */ - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - optional_arg = (sym->attr.optional - || (sym->ns->proc_name->attr.entry_master - && sym->attr.dummy)); - if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmtInit = build3_v (COND_EXPR, tmp, stmtInit, - build_empty_stmt (input_location)); - } - - /* Cleanup code. */ - if (no_repack) - stmtCleanup = NULL_TREE; - else - { - stmtblock_t cleanup; - gfc_start_block (&cleanup); - - if (sym->attr.intent != INTENT_IN) - { - /* Copy the data back. */ - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - - stmtCleanup = gfc_finish_block (&cleanup); - - /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref_loc (input_location, dumdesc); - tmp = gfc_conv_descriptor_data_get (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp, tmpdesc); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - - if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - } - } - - /* We don't need to free any memory allocated by internal_pack as it will - be freed at the end of the function by pop_context. */ - gfc_add_init_cleanup (block, stmtInit, stmtCleanup); - - gfc_restore_backend_locus (&loc); -} - - -/* Calculate the overall offset, including subreferences. */ -static void -gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, - bool subref, gfc_expr *expr) -{ - tree tmp; - tree field; - tree stride; - tree index; - gfc_ref *ref; - gfc_se start; - int n; - - /* If offset is NULL and this is not a subreferenced array, there is - nothing to do. */ - if (offset == NULL_TREE) - { - if (subref) - offset = gfc_index_zero_node; - else - return; - } - - tmp = build_array_ref (desc, offset, NULL); - - /* Offset the data pointer for pointer assignments from arrays with - subreferences; e.g. my_integer => my_type(:)%integer_component. */ - if (subref) - { - /* Go past the array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && - ref->u.ar.type != AR_ELEMENT) - { - ref = ref->next; - break; - } - - /* Calculate the offset for each subsequent subreference. */ - for (; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - field = ref->u.c.component->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), - tmp, field, NULL_TREE); - break; - - case REF_SUBSTRING: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); - gfc_add_block_to_block (block, &start.pre); - tmp = gfc_build_array_ref (tmp, start.expr, NULL); - break; - - case REF_ARRAY: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE - && ref->u.ar.type == AR_ELEMENT); - - /* TODO - Add bounds checking. */ - stride = gfc_index_one_node; - index = gfc_index_zero_node; - for (n = 0; n < ref->u.ar.dimen; n++) - { - tree itmp; - tree jtmp; - - /* Update the index. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type); - itmp = gfc_evaluate_now (start.expr, block); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); - jtmp = gfc_evaluate_now (start.expr, block); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, itmp, jtmp); - itmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, itmp, stride); - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, itmp, index); - index = gfc_evaluate_now (index, block); - - /* Update the stride. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, start.expr, - jtmp); - itmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, itmp); - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, itmp); - stride = gfc_evaluate_now (stride, block); - } - - /* Apply the index to obtain the array element. */ - tmp = gfc_build_array_ref (tmp, index, NULL); - break; - - default: - gcc_unreachable (); - break; - } - } - } - - /* Set the target data pointer. */ - offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); - gfc_conv_descriptor_data_set (block, parm, offset); -} - - -/* gfc_conv_expr_descriptor needs the string length an expression - so that the size of the temporary can be obtained. This is done - by adding up the string lengths of all the elements in the - expression. Function with non-constant expressions have their - string lengths mapped onto the actual arguments using the - interface mapping machinery in trans-expr.c. */ -static void -get_array_charlen (gfc_expr *expr, gfc_se *se) -{ - gfc_interface_mapping mapping; - gfc_formal_arglist *formal; - gfc_actual_arglist *arg; - gfc_se tse; - - if (expr->ts.u.cl->length - && gfc_is_constant_expr (expr->ts.u.cl->length)) - { - if (!expr->ts.u.cl->backend_decl) - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - return; - } - - switch (expr->expr_type) - { - case EXPR_OP: - get_array_charlen (expr->value.op.op1, se); - - /* For parentheses the expression ts.u.cl is identical. */ - if (expr->value.op.op == INTRINSIC_PARENTHESES) - return; - - expr->ts.u.cl->backend_decl = - gfc_create_var (gfc_charlen_type_node, "sln"); - - if (expr->value.op.op2) - { - get_array_charlen (expr->value.op.op2, se); - - gcc_assert (expr->value.op.op == INTRINSIC_CONCAT); - - /* Add the string lengths and assign them to the expression - string length backend declaration. */ - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_build2_loc (input_location, PLUS_EXPR, - gfc_charlen_type_node, - expr->value.op.op1->ts.u.cl->backend_decl, - expr->value.op.op2->ts.u.cl->backend_decl)); - } - else - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - expr->value.op.op1->ts.u.cl->backend_decl); - break; - - case EXPR_FUNCTION: - if (expr->value.function.esym == NULL - || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } - - /* Map expressions involving the dummy arguments onto the actual - argument expressions. */ - gfc_init_interface_mapping (&mapping); - formal = gfc_sym_get_dummy_args (expr->symtree->n.sym); - arg = expr->value.function.actual; - - /* Set se = NULL in the calls to the interface mapping, to suppress any - backend stuff. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) - { - if (!arg->expr) - continue; - if (formal->sym) - gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); - } - - gfc_init_se (&tse, NULL); - - /* Build the expression for the character length and convert it. */ - gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); - - gfc_add_block_to_block (&se->pre, &tse.pre); - gfc_add_block_to_block (&se->post, &tse.post); - tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); - tse.expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_charlen_type_node, tse.expr, - build_int_cst (gfc_charlen_type_node, 0)); - expr->ts.u.cl->backend_decl = tse.expr; - gfc_free_interface_mapping (&mapping); - break; - - default: - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } -} - - -/* Helper function to check dimensions. */ -static bool -transposed_dims (gfc_ss *ss) -{ - int n; - - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] != n) - return true; - return false; -} - - -/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an - AR_FULL, suitable for the scalarizer. */ - -static gfc_ss * -walk_coarray (gfc_expr *e) -{ - gfc_ss *ss; - - gcc_assert (gfc_get_corank (e) > 0); - - ss = gfc_walk_expr (e); - - /* Fix scalar coarray. */ - if (ss == gfc_ss_terminator) - { - gfc_ref *ref; - - ref = e->ref; - while (ref) - { - if (ref->type == REF_ARRAY - && ref->u.ar.codimen > 0) - break; - - ref = ref->next; - } - - gcc_assert (ref != NULL); - if (ref->u.ar.type == AR_ELEMENT) - ref->u.ar.type = AR_SECTION; - ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); - } - - return ss; -} - - -/* Convert an array for passing as an actual argument. Expressions and - vector subscripts are evaluated and stored in a temporary, which is then - passed. For whole arrays the descriptor is passed. For array sections - a modified copy of the descriptor is passed, but using the original data. - - This function is also used for array pointer assignments, and there - are three cases: - - - se->want_pointer && !se->direct_byref - EXPR is an actual argument. On exit, se->expr contains a - pointer to the array descriptor. - - - !se->want_pointer && !se->direct_byref - EXPR is an actual argument to an intrinsic function or the - left-hand side of a pointer assignment. On exit, se->expr - contains the descriptor for EXPR. - - - !se->want_pointer && se->direct_byref - EXPR is the right-hand side of a pointer assignment and - se->expr is the descriptor for the previously-evaluated - left-hand side. The function creates an assignment from - EXPR to se->expr. - - - The se->force_tmp flag disables the non-copying descriptor optimization - that is used for transpose. It may be used in cases where there is an - alias between the transpose argument and another argument in the same - function call. */ - -void -gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - gfc_loopinfo loop; - gfc_array_info *info; - int need_tmp; - int n; - tree tmp; - tree desc; - stmtblock_t block; - tree start; - tree offset; - int full; - bool subref_array_target = false; - gfc_expr *arg, *ss_expr; - - if (se->want_coarray) - ss = walk_coarray (expr); - else - ss = gfc_walk_expr (expr); - - gcc_assert (ss != NULL); - gcc_assert (ss != gfc_ss_terminator); - - ss_info = ss->info; - ss_type = ss_info->type; - ss_expr = ss_info->expr; - - /* Special case: TRANSPOSE which needs no temporary. */ - while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym - && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr))) - { - /* This is a call to transpose which has already been handled by the - scalarizer, so that we just need to get its argument's descriptor. */ - gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); - expr = expr->value.function.actual->expr; - } - - /* Special case things we know we can pass easily. */ - switch (expr->expr_type) - { - case EXPR_VARIABLE: - /* If we have a linear array section, we can pass it directly. - Otherwise we need to copy it into a temporary. */ - - gcc_assert (ss_type == GFC_SS_SECTION); - gcc_assert (ss_expr == expr); - info = &ss_info->data.array; - - /* Get the descriptor for the array. */ - gfc_conv_ss_descriptor (&se->pre, ss, 0); - desc = info->descriptor; - - subref_array_target = se->direct_byref && is_subref_array (expr); - need_tmp = gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target; - - if (se->force_tmp) - need_tmp = 1; - - if (need_tmp) - full = 0; - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - /* Create a new descriptor if the array doesn't have one. */ - full = 0; - } - else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) - full = 1; - else if (se->direct_byref) - full = 0; - else - full = gfc_full_array_ref_p (info->ref, NULL); - - if (full && !transposed_dims (ss)) - { - if (se->direct_byref && !se->byref_noassign) - { - /* Copy the descriptor for pointer assignments. */ - gfc_add_modify (&se->pre, se->expr, desc); - - /* Add any offsets from subreferences. */ - gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, - subref_array_target, expr); - } - else if (se->want_pointer) - { - /* We pass full arrays directly. This means that pointers and - allocatable arrays should also work. */ - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - } - else - { - se->expr = desc; - } - - if (expr->ts.type == BT_CHARACTER) - se->string_length = gfc_get_expr_charlen (expr); - - gfc_free_ss_chain (ss); - return; - } - break; - - case EXPR_FUNCTION: - /* A transformational function return value will be a temporary - array descriptor. We still need to go through the scalarizer - to create the descriptor. Elemental functions are handled as - arbitrary expressions, i.e. copy to a temporary. */ - - if (se->direct_byref) - { - gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr); - - /* For pointer assignments pass the descriptor directly. */ - if (se->ss == NULL) - se->ss = ss; - else - gcc_assert (se->ss == ss); - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - gfc_conv_expr (se, expr); - gfc_free_ss_chain (ss); - return; - } - - if (ss_expr != expr || ss_type != GFC_SS_FUNCTION) - { - if (ss_expr != expr) - /* Elemental function. */ - gcc_assert ((expr->value.function.esym != NULL - && expr->value.function.esym->attr.elemental) - || (expr->value.function.isym != NULL - && expr->value.function.isym->elemental) - || gfc_inline_intrinsic_function_p (expr)); - else - gcc_assert (ss_type == GFC_SS_INTRINSIC); - - need_tmp = 1; - if (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - get_array_charlen (expr, se); - - info = NULL; - } - else - { - /* Transformational function. */ - info = &ss_info->data.array; - need_tmp = 0; - } - break; - - case EXPR_ARRAY: - /* Constant array constructors don't need a temporary. */ - if (ss_type == GFC_SS_CONSTRUCTOR - && expr->ts.type != BT_CHARACTER - && gfc_constant_array_constructor_p (expr->value.constructor)) - { - need_tmp = 0; - info = &ss_info->data.array; - } - else - { - need_tmp = 1; - info = NULL; - } - break; - - default: - /* Something complicated. Copy it into a temporary. */ - need_tmp = 1; - info = NULL; - break; - } - - /* If we are creating a temporary, we don't need to bother about aliases - anymore. */ - if (need_tmp) - se->force_tmp = 0; - - gfc_init_loopinfo (&loop); - - /* Associate the SS with the loop. */ - gfc_add_ss_to_loop (&loop, ss); - - /* Tell the scalarizer not to bother creating loop variables, etc. */ - if (!need_tmp) - loop.array_parameter = 1; - else - /* The right-hand side of a pointer assignment mustn't use a temporary. */ - gcc_assert (!se->direct_byref); - - /* Setup the scalarizing loops and bounds. */ - gfc_conv_ss_startstride (&loop); - - if (need_tmp) - { - if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) - get_array_charlen (expr, se); - - /* Tell the scalarizer to make a temporary. */ - loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), - ((expr->ts.type == BT_CHARACTER) - ? expr->ts.u.cl->backend_decl - : NULL), - loop.dimen); - - se->string_length = loop.temp_ss->info->string_length; - gcc_assert (loop.temp_ss->dimen == loop.dimen); - gfc_add_ss_to_loop (&loop, loop.temp_ss); - } - - gfc_conv_loop_setup (&loop, & expr->where); - - if (need_tmp) - { - /* Copy into a temporary and pass that. We don't need to copy the data - back because expressions and vector subscripts must be INTENT_IN. */ - /* TODO: Optimize passing function return values. */ - gfc_se lse; - gfc_se rse; - - /* Start the copying loops. */ - gfc_mark_ss_chain_used (loop.temp_ss, 1); - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &block); - - /* Copy each data element. */ - gfc_init_se (&lse, NULL); - gfc_copy_loopinfo_to_se (&lse, &loop); - gfc_init_se (&rse, NULL); - gfc_copy_loopinfo_to_se (&rse, &loop); - - lse.ss = loop.temp_ss; - rse.ss = ss; - - gfc_conv_scalarized_array_ref (&lse, NULL); - if (expr->ts.type == BT_CHARACTER) - { - gfc_conv_expr (&rse, expr); - if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) - rse.expr = build_fold_indirect_ref_loc (input_location, - rse.expr); - } - else - gfc_conv_expr_val (&rse, expr); - - gfc_add_block_to_block (&block, &rse.pre); - gfc_add_block_to_block (&block, &lse.pre); - - lse.string_length = rse.string_length; - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, - expr->expr_type == EXPR_VARIABLE - || expr->expr_type == EXPR_ARRAY, true); - gfc_add_expr_to_block (&block, tmp); - - /* Finish the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &block); - - desc = loop.temp_ss->info->data.array.descriptor; - } - else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) - { - desc = info->descriptor; - se->string_length = ss_info->string_length; - } - else - { - /* We pass sections without copying to a temporary. Make a new - descriptor and point it at the section we want. The loop variable - limits will be the limits of the section. - A function may decide to repack the array to speed up access, but - we're not bothered about that here. */ - int dim, ndim, codim; - tree parm; - tree parmtype; - tree stride; - tree from; - tree to; - tree base; - - ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; - - if (se->want_coarray) - { - gfc_array_ref *ar = &info->ref->u.ar; - - codim = gfc_get_corank (expr); - for (n = 0; n < codim - 1; n++) - { - /* Make sure we are not lost somehow. */ - gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); - - /* Make sure the call to gfc_conv_section_startstride won't - generate unnecessary code to calculate stride. */ - gcc_assert (ar->stride[n + ndim] == NULL); - - gfc_conv_section_startstride (&loop, ss, n + ndim); - loop.from[n + loop.dimen] = info->start[n + ndim]; - loop.to[n + loop.dimen] = info->end[n + ndim]; - } - - gcc_assert (n == codim - 1); - evaluate_bound (&loop.pre, info->start, ar->start, - info->descriptor, n + ndim, true); - loop.from[n + loop.dimen] = info->start[n + ndim]; - } - else - codim = 0; - - /* Set the string_length for a character array. */ - if (expr->ts.type == BT_CHARACTER) - se->string_length = gfc_get_expr_charlen (expr); - - desc = info->descriptor; - if (se->direct_byref && !se->byref_noassign) - { - /* For pointer assignments we fill in the destination. */ - parm = se->expr; - parmtype = TREE_TYPE (parm); - } - else - { - /* Otherwise make a new one. */ - parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, - loop.from, loop.to, 0, - GFC_ARRAY_UNKNOWN, false); - parm = gfc_create_var (parmtype, "parm"); - } - - offset = gfc_index_zero_node; - - /* The following can be somewhat confusing. We have two - descriptors, a new one and the original array. - {parm, parmtype, dim} refer to the new one. - {desc, type, n, loop} refer to the original, which maybe - a descriptorless array. - The bounds of the scalarization are the bounds of the section. - We don't have to worry about numeric overflows when calculating - the offsets because all elements are within the array data. */ - - /* Set the dtype. */ - tmp = gfc_conv_descriptor_dtype (parm); - gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); - - /* Set offset for assignments to pointer only to zero if it is not - the full array. */ - if (se->direct_byref - && info->ref && info->ref->u.ar.type != AR_FULL) - base = gfc_index_zero_node; - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre); - else - base = NULL_TREE; - - for (n = 0; n < ndim; n++) - { - stride = gfc_conv_array_stride (desc, n); - - /* Work out the offset. */ - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - gcc_assert (info->subscript[n] - && info->subscript[n]->info->type == GFC_SS_SCALAR); - start = info->subscript[n]->info->data.scalar.value; - } - else - { - /* Evaluate and remember the start of the section. */ - start = info->start[n]; - stride = gfc_evaluate_now (stride, &loop.pre); - } - - tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), - start, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, stride); - offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), - offset, tmp); - - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - /* For elemental dimensions, we only need the offset. */ - continue; - } - - /* Vector subscripts need copying and are handled elsewhere. */ - if (info->ref) - gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); - - /* look for the corresponding scalarizer dimension: dim. */ - for (dim = 0; dim < ndim; dim++) - if (ss->dim[dim] == n) - break; - - /* loop exited early: the DIM being looked for has been found. */ - gcc_assert (dim < ndim); - - /* Set the new lower bound. */ - from = loop.from[dim]; - to = loop.to[dim]; - - /* If we have an array section or are assigning make sure that - the lower bound is 1. References to the full - array should otherwise keep the original bounds. */ - if ((!info->ref - || info->ref->u.ar.type != AR_FULL) - && !integer_onep (from)) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, gfc_index_one_node, - from); - to = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, to, tmp); - from = gfc_index_one_node; - } - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[dim], from); - - /* Set the new upper bound. */ - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[dim], to); - - /* Multiply the stride by the section stride to get the - total stride. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - stride, info->stride[n]); - - if (se->direct_byref - && info->ref - && info->ref->u.ar.type != AR_FULL) - { - base = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), base, stride); - } - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), tmp, loop.from[dim]); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (base), tmp, - gfc_conv_array_stride (desc, n)); - base = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (base), tmp, base); - } - - /* Store the new stride. */ - gfc_conv_descriptor_stride_set (&loop.pre, parm, - gfc_rank_cst[dim], stride); - } - - for (n = loop.dimen; n < loop.dimen + codim; n++) - { - from = loop.from[n]; - to = loop.to[n]; - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[n], from); - if (n < loop.dimen + codim - 1) - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[n], to); - } - - if (se->data_not_needed) - gfc_conv_descriptor_data_set (&loop.pre, parm, - gfc_index_zero_node); - else - /* Point the data pointer at the 1st element in the section. */ - gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, - subref_array_target, expr); - - if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - && !se->data_not_needed) - { - /* Set the offset. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, base); - } - else - { - /* Only the callee knows what the correct offset it, so just set - it to zero here. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); - } - desc = parm; - } - - if (!se->direct_byref || se->byref_noassign) - { - /* Get a pointer to the new descriptor. */ - if (se->want_pointer) - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - else - se->expr = desc; - } - - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->post, &loop.post); - - /* Cleanup the scalarizer. */ - gfc_cleanup_loop (&loop); -} - -/* Helper function for gfc_conv_array_parameter if array size needs to be - computed. */ - -static void -array_parameter_size (tree desc, gfc_expr *expr, tree *size) -{ - tree elem; - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - else if (expr->rank > 1) - *size = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, - gfc_build_addr_expr (NULL, desc)); - else - { - tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); - tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - - *size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *size, gfc_index_one_node); - *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - *size, gfc_index_zero_node); - } - elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - *size, fold_convert (gfc_array_index_type, elem)); -} - -/* Convert an array for passing as an actual parameter. */ -/* TODO: Optimize passing g77 arrays. */ - -void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, - const gfc_symbol *fsym, const char *proc_name, - tree *size) -{ - tree ptr; - tree desc; - tree tmp = NULL_TREE; - tree stmt; - tree parent = DECL_CONTEXT (current_function_decl); - bool full_array_var; - bool this_array_result; - bool contiguous; - bool no_pack; - bool array_constructor; - bool good_allocatable; - bool ultimate_ptr_comp; - bool ultimate_alloc_comp; - gfc_symbol *sym; - stmtblock_t block; - gfc_ref *ref; - - ultimate_ptr_comp = false; - ultimate_alloc_comp = false; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->next == NULL) - break; - - if (ref->type == REF_COMPONENT) - { - ultimate_ptr_comp = ref->u.c.component->attr.pointer; - ultimate_alloc_comp = ref->u.c.component->attr.allocatable; - } - } - - full_array_var = false; - contiguous = false; - - if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) - full_array_var = gfc_full_array_ref_p (ref, &contiguous); - - sym = full_array_var ? expr->symtree->n.sym : NULL; - - /* The symbol should have an array specification. */ - gcc_assert (!sym || sym->as || ref->u.ar.as); - - if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) - { - get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); - expr->ts.u.cl->backend_decl = tmp; - se->string_length = tmp; - } - - /* Is this the result of the enclosing procedure? */ - this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); - if (this_array_result - && (sym->backend_decl != current_function_decl) - && (sym->backend_decl != parent)) - this_array_result = false; - - /* Passing address of the array if it is not pointer or assumed-shape. */ - if (full_array_var && g77 && !this_array_result - && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - { - tmp = gfc_get_symbol_decl (sym); - - if (sym->ts.type == BT_CHARACTER) - se->string_length = sym->ts.u.cl->backend_decl; - - if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && !sym->attr.allocatable) - { - /* Some variables are declared directly, others are declared as - pointers and allocated on the heap. */ - if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp))) - se->expr = tmp; - else - se->expr = gfc_build_addr_expr (NULL_TREE, tmp); - if (size) - array_parameter_size (tmp, expr, size); - return; - } - - if (sym->attr.allocatable) - { - if (sym->attr.dummy || sym->attr.result) - { - gfc_conv_expr_descriptor (se, expr); - tmp = se->expr; - } - if (size) - array_parameter_size (tmp, expr, size); - se->expr = gfc_conv_array_data (tmp); - return; - } - } - - /* A convenient reduction in scope. */ - contiguous = g77 && !this_array_result && contiguous; - - /* There is no need to pack and unpack the array, if it is contiguous - and not a deferred- or assumed-shape array, or if it is simply - contiguous. */ - no_pack = ((sym && sym->as - && !sym->attr.pointer - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && sym->as->type != AS_ASSUMED_SHAPE) - || - (ref && ref->u.ar.as - && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_RANK - && ref->u.ar.as->type != AS_ASSUMED_SHAPE) - || - gfc_is_simply_contiguous (expr, false)); - - no_pack = contiguous && no_pack; - - /* Array constructors are always contiguous and do not need packing. */ - array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; - - /* Same is true of contiguous sections from allocatable variables. */ - good_allocatable = contiguous - && expr->symtree - && expr->symtree->n.sym->attr.allocatable; - - /* Or ultimate allocatable components. */ - ultimate_alloc_comp = contiguous && ultimate_alloc_comp; - - if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) - { - gfc_conv_expr_descriptor (se, expr); - if (expr->ts.type == BT_CHARACTER) - se->string_length = expr->ts.u.cl->backend_decl; - if (size) - array_parameter_size (se->expr, expr, size); - se->expr = gfc_conv_array_data (se->expr); - return; - } - - if (this_array_result) - { - /* Result of the enclosing function. */ - gfc_conv_expr_descriptor (se, expr); - if (size) - array_parameter_size (se->expr, expr, size); - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - - if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) - se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, - se->expr)); - - return; - } - else - { - /* Every other type of array. */ - se->want_pointer = 1; - gfc_conv_expr_descriptor (se, expr); - if (size) - array_parameter_size (build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); - } - - /* Deallocate the allocatable components of structures that are - not variable. */ - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); - - /* The components shall be deallocated before their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } - - if (g77 || (fsym && fsym->attr.contiguous - && !gfc_is_simply_contiguous (expr, false))) - { - tree origptr = NULL_TREE; - - desc = se->expr; - - /* For contiguous arrays, save the original value of the descriptor. */ - if (!g77) - { - origptr = gfc_create_var (pvoid_type_node, "origptr"); - tmp = build_fold_indirect_ref_loc (input_location, desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (origptr), origptr, - fold_convert (TREE_TYPE (origptr), tmp)); - gfc_add_expr_to_block (&se->pre, tmp); - } - - /* Repack the array. */ - if (gfc_option.warn_array_temp) - { - if (fsym) - gfc_warning ("Creating array temporary at %L for argument '%s'", - &expr->where, fsym->name); - else - gfc_warning ("Creating array temporary at %L", &expr->where); - } - - ptr = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, desc); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - { - tmp = gfc_conv_expr_present (sym); - ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), - tmp, fold_convert (TREE_TYPE (se->expr), ptr), - fold_convert (TREE_TYPE (se->expr), null_pointer_node)); - } - - ptr = gfc_evaluate_now (ptr, &se->pre); - - /* Use the packed data for the actual argument, except for contiguous arrays, - where the descriptor's data component is set. */ - if (g77) - se->expr = ptr; - else - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); - } - - if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) - { - char * msg; - - if (fsym && proc_name) - asprintf (&msg, "An array temporary was created for argument " - "'%s' of procedure '%s'", fsym->name, proc_name); - else - asprintf (&msg, "An array temporary was created"); - - tmp = build_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, - gfc_conv_expr_present (sym), tmp); - - gfc_trans_runtime_check (false, true, tmp, &se->pre, - &expr->where, msg); - free (msg); - } - - gfc_start_block (&block); - - /* Copy the data back. */ - if (fsym == NULL || fsym->attr.intent != INTENT_IN) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, desc, ptr); - gfc_add_expr_to_block (&block, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (convert (pvoid_type_node, ptr)); - gfc_add_expr_to_block (&block, tmp); - - stmt = gfc_finish_block (&block); - - gfc_init_block (&block); - /* Only if it was repacked. This code needs to be executed before the - loop cleanup code. */ - tmp = build_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, - gfc_conv_expr_present (sym), tmp); - - tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se->post); - - gfc_init_block (&se->post); - - /* Reset the descriptor pointer. */ - if (!g77) - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - gfc_conv_descriptor_data_set (&se->post, tmp, origptr); - } - - gfc_add_block_to_block (&se->post, &block); - } -} - - -/* Generate code to deallocate an array, if it is allocated. */ - -tree -gfc_trans_dealloc_allocated (tree descriptor, bool coarray) -{ - tree tmp; - tree var; - stmtblock_t block; - - gfc_start_block (&block); - - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Call array_deallocate with an int * present in the second argument. - Although it is ignored here, it's presence ensures that arrays that - are already deallocated are ignored. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, coarray); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* This helper function calculates the size in words of a full array. */ - -static tree -get_full_array_size (stmtblock_t *block, tree decl, int rank) -{ - tree idx; - tree nelems; - tree tmp; - idx = gfc_rank_cst[rank - 1]; - nelems = gfc_conv_descriptor_ubound_get (decl, idx); - tmp = gfc_conv_descriptor_lbound_get (decl, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - nelems, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, block); - - nelems = gfc_conv_descriptor_stride_get (decl, idx); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - return gfc_evaluate_now (tmp, block); -} - - -/* Allocate dest to the same size as src, and copy src -> dest. - If no_malloc is set, only the copy is done. */ - -static tree -duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc) -{ - tree tmp; - tree size; - tree nelems; - tree null_cond; - tree null_data; - stmtblock_t block; - - /* If the source is null, set the destination to null. Then, - allocate memory to the destination. */ - gfc_init_block (&block); - - if (rank == 0) - { - tmp = null_pointer_node; - tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp); - gfc_add_expr_to_block (&block, tmp); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); - if (!no_malloc) - { - tmp = gfc_call_malloc (&block, type, size); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - dest, fold_convert (type, tmp)); - gfc_add_expr_to_block (&block, tmp); - } - - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, - fold_convert (size_type_node, size)); - } - else - { - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - nelems = get_full_array_size (&block, src, rank); - tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - if (!no_malloc) - { - tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); - tmp = gfc_call_malloc (&block, tmp, size); - gfc_conv_descriptor_data_set (&block, dest, tmp); - } - - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, - tmp, 3, gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), - fold_convert (size_type_node, size)); - } - - gfc_add_expr_to_block (&block, tmp); - tmp = gfc_finish_block (&block); - - /* Null the destination if the source is null; otherwise do - the allocate and copy. */ - if (rank == 0) - null_cond = src; - else - null_cond = gfc_conv_descriptor_data_get (src); - - null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - null_cond, null_pointer_node); - return build3_v (COND_EXPR, null_cond, tmp, null_data); -} - - -/* Allocate dest to the same size as src, and copy data src -> dest. */ - -tree -gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, false); -} - - -/* Copy data src -> dest. */ - -tree -gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, true); -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate, nullify or copy allocatable components. This is the work horse - function for the functions named in this enum. */ - -enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, - COPY_ONLY_ALLOC_COMP}; - -static tree -structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose) -{ - gfc_component *c; - gfc_loopinfo loop; - stmtblock_t fnblock; - stmtblock_t loopbody; - stmtblock_t tmpblock; - tree decl_type; - tree tmp; - tree comp; - tree dcmp; - tree nelems; - tree index; - tree var; - tree cdecl; - tree ctype; - tree vref, dref; - tree null_cond = NULL_TREE; - bool called_dealloc_with_status; - - gfc_init_block (&fnblock); - - decl_type = TREE_TYPE (decl); - - if ((POINTER_TYPE_P (decl_type) && rank != 0) - || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Just in case in gets dereferenced. */ - decl_type = TREE_TYPE (decl); - - /* If this an array of derived types with allocatable components - build a loop and recursively call this function. */ - if (TREE_CODE (decl_type) == ARRAY_TYPE - || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) - { - tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, - tmp); - - /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (decl_type)) - { - /* Use the descriptor for an allocatable array. Since this - is a full array reference, we only need the descriptor - information from dimension = rank. */ - tmp = get_full_array_size (&fnblock, decl, rank); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - - null_cond = gfc_conv_descriptor_data_get (decl); - null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, null_cond, - build_int_cst (TREE_TYPE (null_cond), 0)); - } - else - { - /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (decl_type); - tmp = fold_convert (gfc_array_index_type, tmp); - } - - /* Remember that this is, in fact, the no. of elements - 1. */ - nelems = gfc_evaluate_now (tmp, &fnblock); - index = gfc_create_var (gfc_array_index_type, "S"); - - /* Build the body of the loop. */ - gfc_init_block (&loopbody); - - vref = gfc_build_array_ref (var, index, NULL); - - if (purpose == COPY_ALLOC_COMP) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); - gfc_add_expr_to_block (&fnblock, tmp); - } - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); - } - else if (purpose == COPY_ONLY_ALLOC_COMP) - { - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP); - } - else - tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose); - - gfc_add_expr_to_block (&loopbody, tmp); - - /* Build the loop and return. */ - gfc_init_loopinfo (&loop); - loop.dimen = 1; - loop.from[0] = gfc_index_zero_node; - loop.loopvar[0] = index; - loop.to[0] = nelems; - gfc_trans_scalarizing_loops (&loop, &loopbody); - gfc_add_block_to_block (&fnblock, &loop.pre); - - tmp = gfc_finish_block (&fnblock); - if (null_cond != NULL_TREE) - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - - return tmp; - } - - /* Otherwise, act on the components or recursively call self to - act on a chain of components. */ - for (c = der_type->components; c; c = c->next) - { - bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED - || c->ts.type == BT_CLASS) - && c->ts.u.derived->attr.alloc_comp; - cdecl = c->backend_decl; - ctype = TREE_TYPE (cdecl); - - switch (purpose) - { - case DEALLOCATE_ALLOC_COMP: - - /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp - (i.e. this function) so generate all the calls and suppress the - recursion from here, if necessary. */ - called_dealloc_with_status = false; - gfc_init_block (&tmpblock); - - if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension) - && !c->attr.proc_pointer) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (c->attr.allocatable) - { - /* Allocatable scalar components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, - c->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) - { - /* Allocatable CLASS components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Add reference to '_data' component. */ - tmp = CLASS_DATA (c)->backend_decl; - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), comp, tmp, NULL_TREE); - - if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp, - CLASS_DATA (c)->attr.codimension); - else - { - tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, - CLASS_DATA (c)->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - } - gfc_add_expr_to_block (&tmpblock, tmp); - } - - if (cmp_has_alloc_comps - && !c->attr.pointer - && !called_dealloc_with_status) - { - /* Do not deallocate the components of ultimate pointer - components or iteratively call self if call has been made - to gfc_trans_dealloc_allocated */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } - - /* Now add the deallocation of this component. */ - gfc_add_block_to_block (&fnblock, &tmpblock); - break; - - case NULLIFY_ALLOC_COMP: - if (c->attr.pointer) - continue; - else if (c->attr.allocatable - && (c->attr.dimension|| c->attr.codimension)) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - } - else if (c->attr.allocatable) - { - /* Allocatable scalar components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) - { - /* Allocatable CLASS components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - /* Add reference to '_data' component. */ - tmp = CLASS_DATA (c)->backend_decl; - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), comp, tmp, NULL_TREE); - if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - else - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - } - else if (cmp_has_alloc_comps) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } - break; - - case COPY_ALLOC_COMP: - if (c->attr.pointer) - continue; - - /* We need source and destination components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, - cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, - cdecl, NULL_TREE); - dcmp = fold_convert (TREE_TYPE (comp), dcmp); - - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) - { - tree ftn_tree; - tree size; - tree dst_data; - tree src_data; - tree null_data; - - dst_data = gfc_class_data_get (dcmp); - src_data = gfc_class_data_get (comp); - size = fold_convert (size_type_node, gfc_vtable_size_get (comp)); - - if (CLASS_DATA (c)->attr.dimension) - { - nelems = gfc_conv_descriptor_size (src_data, - CLASS_DATA (c)->as->rank); - src_data = gfc_conv_descriptor_data_get (src_data); - dst_data = gfc_conv_descriptor_data_get (dst_data); - } - else - nelems = build_int_cst (size_type_node, 1); - - gfc_init_block (&tmpblock); - - /* We need to use CALLOC as _copy might try to free allocatable - components of the destination. */ - ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC); - tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems, - size); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), tmp)); - - tmp = gfc_copy_class_to_class (comp, dcmp, nelems); - gfc_add_expr_to_block (&tmpblock, tmp); - tmp = gfc_finish_block (&tmpblock); - - gfc_init_block (&tmpblock); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), - null_pointer_node)); - null_data = gfc_finish_block (&tmpblock); - - null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, src_data, - null_pointer_node); - - gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, - tmp, null_data)); - continue; - } - - if (c->attr.allocatable && !c->attr.proc_pointer - && !cmp_has_alloc_comps) - { - rank = c->as ? c->as->rank : 0; - tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); - gfc_add_expr_to_block (&fnblock, tmp); - } - - if (cmp_has_alloc_comps) - { - rank = c->as ? c->as->rank : 0; - tmp = fold_convert (TREE_TYPE (dcmp), comp); - gfc_add_modify (&fnblock, dcmp, tmp); - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } - break; - - default: - gcc_unreachable (); - break; - } - } - - return gfc_finish_block (&fnblock); -} - -/* Recursively traverse an object of derived type, generating code to - nullify allocatable components. */ - -tree -gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP); -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate allocatable components. */ - -tree -gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP); -} - - -/* Recursively traverse an object of derived type, generating code to - copy it and its allocatable components. */ - -tree -gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) -{ - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP); -} - - -/* Recursively traverse an object of derived type, generating code to - copy only its allocatable components. */ - -tree -gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) -{ - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP); -} - - -/* Returns the value of LBOUND for an expression. This could be broken out - from gfc_conv_intrinsic_bound but this seemed to be simpler. This is - called by gfc_alloc_allocatable_for_assignment. */ -static tree -get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) -{ - tree lbound; - tree ubound; - tree stride; - tree cond, cond1, cond3, cond4; - tree tmp; - gfc_ref *ref; - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - tmp = gfc_rank_cst[dim]; - lbound = gfc_conv_descriptor_lbound_get (desc, tmp); - ubound = gfc_conv_descriptor_ubound_get (desc, tmp); - stride = gfc_conv_descriptor_stride_get (desc, tmp); - cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - if (assumed_size) - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - tmp, build_int_cst (gfc_array_index_type, - expr->rank - 1)); - else - cond = boolean_false_node; - - cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond1); - - return fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - lbound, gfc_index_one_node); - } - - if (expr->expr_type == EXPR_FUNCTION) - { - /* A conversion function, so use the argument. */ - gcc_assert (expr->value.function.isym - && expr->value.function.isym->conversion); - expr = expr->value.function.actual->expr; - } - - if (expr->expr_type == EXPR_VARIABLE) - { - tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->as - && ref->next - && ref->next->u.ar.type == AR_FULL) - tmp = TREE_TYPE (ref->u.c.component->backend_decl); - } - return GFC_TYPE_ARRAY_LBOUND(tmp, dim); - } - - return gfc_index_one_node; -} - - -/* Returns true if an expression represents an lhs that can be reallocated - on assignment. */ - -bool -gfc_is_reallocatable_lhs (gfc_expr *expr) -{ - gfc_ref * ref; - - if (!expr->ref) - return false; - - /* An allocatable variable. */ - if (expr->symtree->n.sym->attr.allocatable - && expr->ref - && expr->ref->type == REF_ARRAY - && expr->ref->u.ar.type == AR_FULL) - return true; - - /* All that can be left are allocatable components. */ - if ((expr->symtree->n.sym->ts.type != BT_DERIVED - && expr->symtree->n.sym->ts.type != BT_CLASS) - || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) - return false; - - /* Find a component ref followed by an array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->next - && ref->type == REF_COMPONENT - && ref->next->type == REF_ARRAY - && !ref->next->next) - break; - - if (!ref) - return false; - - /* Return true if valid reallocatable lhs. */ - if (ref->u.c.component->attr.allocatable - && ref->next->u.ar.type == AR_FULL) - return true; - - return false; -} - - -/* Allocate the lhs of an assignment to an allocatable array, otherwise - reallocate it. */ - -tree -gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, - gfc_expr *expr1, - gfc_expr *expr2) -{ - stmtblock_t realloc_block; - stmtblock_t alloc_block; - stmtblock_t fblock; - gfc_ss *rss; - gfc_ss *lss; - gfc_array_info *linfo; - tree realloc_expr; - tree alloc_expr; - tree size1; - tree size2; - tree array1; - tree cond; - tree tmp; - tree tmp2; - tree lbound; - tree ubound; - tree desc; - tree old_desc; - tree desc2; - tree offset; - tree jump_label1; - tree jump_label2; - tree neq_size; - tree lbd; - int n; - int dim; - gfc_array_spec * as; - - /* x = f(...) with x allocatable. In this case, expr1 is the rhs. - Find the lhs expression in the loop chain and set expr1 and - expr2 accordingly. */ - if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) - { - expr2 = expr1; - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE) - break; - if (lss == gfc_ss_terminator) - return NULL_TREE; - expr1 = lss->info->expr; - } - - /* Bail out if this is not a valid allocate on assignment. */ - if (!gfc_is_reallocatable_lhs (expr1) - || (expr2 && !expr2->rank)) - return NULL_TREE; - - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr == expr1) - break; - - if (lss == gfc_ss_terminator) - return NULL_TREE; - - linfo = &lss->info->data.array; - - /* Find an ss for the rhs. For operator expressions, we see the - ss's for the operands. Any one of these will do. */ - rss = loop->ss; - for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) - if (rss->info->expr != expr1 && rss != loop->temp_ss) - break; - - if (expr2 && rss == gfc_ss_terminator) - return NULL_TREE; - - gfc_start_block (&fblock); - - /* Since the lhs is allocatable, this must be a descriptor type. - Get the data and array size. */ - desc = linfo->descriptor; - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); - array1 = gfc_conv_descriptor_data_get (desc); - - /* 7.4.1.3 "If variable is an allocated allocatable variable, it is - deallocated if expr is an array of different shape or any of the - corresponding length type parameter values of variable and expr - differ." This assures F95 compatibility. */ - jump_label1 = gfc_build_label_decl (NULL_TREE); - jump_label2 = gfc_build_label_decl (NULL_TREE); - - /* Allocate if data is NULL. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - array1, build_int_cst (TREE_TYPE (array1), 0)); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - - /* Get arrayspec if expr is a full array. */ - if (expr2 && expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym - && expr2->value.function.isym->conversion) - { - /* For conversion functions, take the arg. */ - gfc_expr *arg = expr2->value.function.actual->expr; - as = gfc_get_full_arrayspec_from_expr (arg); - } - else if (expr2) - as = gfc_get_full_arrayspec_from_expr (expr2); - else - as = NULL; - - /* If the lhs shape is not the same as the rhs jump to setting the - bounds and doing the reallocation....... */ - for (n = 0; n < expr1->rank; n++) - { - /* Check the shape. */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, lbound); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - tmp, ubound); - cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, - tmp, gfc_index_zero_node); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - } - - /* ....else jump past the (re)alloc code. */ - tmp = build1_v (GOTO_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - /* Add the label to start automatic (re)allocation. */ - tmp = build1_v (LABEL_EXPR, jump_label1); - gfc_add_expr_to_block (&fblock, tmp); - - size1 = gfc_conv_descriptor_size (desc, expr1->rank); - - /* Get the rhs size. Fix both sizes. */ - if (expr2) - desc2 = rss->info->data.array.descriptor; - else - desc2 = NULL_TREE; - size2 = gfc_index_one_node; - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size2); - } - - size1 = gfc_evaluate_now (size1, &fblock); - size2 = gfc_evaluate_now (size2, &fblock); - - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - size1, size2); - neq_size = gfc_evaluate_now (cond, &fblock); - - /* Deallocation of allocatable components will have to occur on - reallocation. Fix the old descriptor now. */ - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - old_desc = gfc_evaluate_now (desc, &fblock); - else - old_desc = NULL_TREE; - - /* Now modify the lhs descriptor and the associated scalarizer - variables. F2003 7.4.1.3: "If variable is or becomes an - unallocated allocatable variable, then it is allocated with each - deferred type parameter equal to the corresponding type parameters - of expr , with the shape of expr , and with each lower bound equal - to the corresponding element of LBOUND(expr)." - Reuse size1 to keep a dimension-by-dimension track of the - stride of the new array. */ - size1 = gfc_index_one_node; - offset = gfc_index_zero_node; - - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - - lbound = gfc_index_one_node; - ubound = tmp; - - if (as) - { - lbd = get_std_lbound (expr2, desc2, n, - as->type == AS_ASSUMED_SIZE); - ubound = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - ubound, lbound); - ubound = fold_build2_loc (input_location, - PLUS_EXPR, - gfc_array_index_type, - ubound, lbd); - lbound = lbd; - } - - gfc_conv_descriptor_lbound_set (&fblock, desc, - gfc_rank_cst[n], - lbound); - gfc_conv_descriptor_ubound_set (&fblock, desc, - gfc_rank_cst[n], - ubound); - gfc_conv_descriptor_stride_set (&fblock, desc, - gfc_rank_cst[n], - size1); - lbound = gfc_conv_descriptor_lbound_get (desc, - gfc_rank_cst[n]); - tmp2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - lbound, size1); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp2); - size1 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size1); - } - - /* Set the lhs descriptor and scalarizer offsets. For rank > 1, - the array offset is saved and the info.offset is used for a - running offset. Use the saved_offset instead. */ - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && TREE_CODE (linfo->saved_offset) == VAR_DECL) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); - - /* Now set the deltas for the lhs. */ - for (n = 0; n < expr1->rank; n++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - dim = lss->dim[n]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - loop->from[dim]); - if (linfo->delta[dim] - && TREE_CODE (linfo->delta[dim]) == VAR_DECL) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); - } - - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - tmp = expr2->ts.u.cl->backend_decl; - gcc_assert (expr1->ts.u.cl->backend_decl); - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); - tmp = fold_convert (gfc_array_index_type, tmp); - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size2); - size2 = fold_convert (size_type_node, size2); - size2 = gfc_evaluate_now (size2, &fblock); - - /* Realloc expression. Note that the scalarizer uses desc.data - in the array reference - (*desc.data)[<element>]. */ - gfc_init_block (&realloc_block); - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_REALLOC), 2, - fold_convert (pvoid_type_node, array1), - size2); - gfc_conv_descriptor_data_set (&realloc_block, - desc, tmp); - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - realloc_expr = gfc_finish_block (&realloc_block); - - /* Only reallocate if sizes are different. */ - tmp = build3_v (COND_EXPR, neq_size, realloc_expr, - build_empty_stmt (input_location)); - realloc_expr = tmp; - - - /* Malloc expression. */ - gfc_init_block (&alloc_block); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), - 1, size2); - gfc_conv_descriptor_data_set (&alloc_block, - desc, tmp); - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&alloc_block, tmp); - } - alloc_expr = gfc_finish_block (&alloc_block); - - /* Malloc if not allocated; realloc otherwise. */ - tmp = build_int_cst (TREE_TYPE (array1), 0); - cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, - array1, tmp); - tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); - gfc_add_expr_to_block (&fblock, tmp); - - /* Make sure that the scalarizer data pointer is updated. */ - if (linfo->data - && TREE_CODE (linfo->data) == VAR_DECL) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - return gfc_finish_block (&fblock); -} - - -/* NULLIFY an allocatable/pointer array on function entry, free it on exit. - Do likewise, recursively if necessary, with the allocatable components of - derived types. */ - -void -gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree type; - tree tmp; - tree descriptor; - stmtblock_t init; - stmtblock_t cleanup; - locus loc; - int rank; - bool sym_has_alloc_comp; - - sym_has_alloc_comp = (sym->ts.type == BT_DERIVED - || sym->ts.type == BT_CLASS) - && sym->ts.u.derived->attr.alloc_comp; - - /* Make sure the frontend gets these right. */ - if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) - fatal_error ("Possible front-end bug: Deferred array size without pointer, " - "allocatable attribute or derived type without allocatable " - "components."); - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_init_block (&init); - - gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL - || TREE_CODE (sym->backend_decl) == PARM_DECL); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &init); - } - - /* Dummy, use associated and result variables don't need anything special. */ - if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - descriptor = sym->backend_decl; - - /* Although static, derived types with default initializers and - allocatable components must not be nulled wholesale; instead they - are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp) - { - /* SAVEd variables are not freed on exit. */ - gfc_trans_static_array_pointer (sym); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - /* Get the descriptor type. */ - type = TREE_TYPE (sym->backend_decl); - - if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) - { - if (!sym->attr.save - && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) - { - if (sym->value == NULL - || !gfc_has_default_initializer (sym->ts.u.derived)) - { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, - descriptor, rank); - gfc_add_expr_to_block (&init, tmp); - } - else - gfc_init_default_dt (sym, &init, false); - } - } - else if (!GFC_DESCRIPTOR_TYPE_P (type)) - { - /* If the backend_decl is not a descriptor, we must have a pointer - to one. */ - descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); - type = TREE_TYPE (descriptor); - } - - /* NULLIFY the data pointer. */ - if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) - gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); - - gfc_restore_backend_locus (&loc); - gfc_init_block (&cleanup); - - /* Allocatable arrays need to be freed when they go out of scope. - The allocatable components of pointers must not be touched. */ - if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) - && !sym->attr.pointer && !sym->attr.save) - { - int rank; - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&cleanup, tmp); - } - - if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) - && !sym->attr.save && !sym->attr.result) - { - tmp = gfc_trans_dealloc_allocated (sym->backend_decl, - sym->attr.codimension); - gfc_add_expr_to_block (&cleanup, tmp); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&init), - gfc_finish_block (&cleanup)); -} - -/************ Expression Walking Functions ******************/ - -/* Walk a variable reference. - - Possible extension - multiple component subscripts. - x(:,:) = foo%a(:)%b(:) - Transforms to - forall (i=..., j=...) - x(i,j) = foo%a(j)%b(i) - end forall - This adds a fair amount of complexity because you need to deal with more - than one ref. Maybe handle in a similar manner to vector subscripts. - Maybe not worth the effort. */ - - -static gfc_ss * -gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ref *ref; - - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - break; - - return gfc_walk_array_ref (ss, expr, ref); -} - - -gfc_ss * -gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) -{ - gfc_array_ref *ar; - gfc_ss *newss; - int n; - - for (; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING) - { - ss = gfc_get_scalar_ss (ss, ref->u.ss.start); - ss = gfc_get_scalar_ss (ss, ref->u.ss.end); - } - - /* We're only interested in array sections from now on. */ - if (ref->type != REF_ARRAY) - continue; - - ar = &ref->u.ar; - - switch (ar->type) - { - case AR_ELEMENT: - for (n = ar->dimen - 1; n >= 0; n--) - ss = gfc_get_scalar_ss (ss, ar->start[n]); - break; - - case AR_FULL: - newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* Make sure array is the same as array(:,:), this way - we don't need to special case all the time. */ - ar->dimen = ar->as->rank; - for (n = 0; n < ar->dimen; n++) - { - ar->dimen_type[n] = DIMEN_RANGE; - - gcc_assert (ar->start[n] == NULL); - gcc_assert (ar->end[n] == NULL); - gcc_assert (ar->stride[n] == NULL); - } - ss = newss; - break; - - case AR_SECTION: - newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* We add SS chains for all the subscripts in the section. */ - for (n = 0; n < ar->dimen; n++) - { - gfc_ss *indexss; - - switch (ar->dimen_type[n]) - { - case DIMEN_ELEMENT: - /* Add SS for elemental (scalar) subscripts. */ - gcc_assert (ar->start[n]); - indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - break; - - case DIMEN_RANGE: - /* We don't add anything for sections, just remember this - dimension for later. */ - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - case DIMEN_VECTOR: - /* Create a GFC_SS_VECTOR index in which we can store - the vector's descriptor. */ - indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], - 1, GFC_SS_VECTOR); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - } - /* We should have at least one non-elemental dimension, - unless we are creating a descriptor for a (scalar) coarray. */ - gcc_assert (newss->dimen > 0 - || newss->info->data.array.ref->u.ar.as->corank > 0); - ss = newss; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - - } - return ss; -} - - -/* Walk an expression operator. If only one operand of a binary expression is - scalar, we must also add the scalar term to the SS chain. */ - -static gfc_ss * -gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - gfc_ss *head2; - - head = gfc_walk_subexpr (ss, expr->value.op.op1); - if (expr->value.op.op2 == NULL) - head2 = head; - else - head2 = gfc_walk_subexpr (head, expr->value.op.op2); - - /* All operands are scalar. Pass back and let the caller deal with it. */ - if (head2 == ss) - return head2; - - /* All operands require scalarization. */ - if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) - return head2; - - /* One of the operands needs scalarization, the other is scalar. - Create a gfc_ss for the scalar expression. */ - if (head == ss) - { - /* First operand is scalar. We build the chain in reverse order, so - add the scalar SS after the second operand. */ - head = head2; - while (head && head->next != ss) - head = head->next; - /* Check we haven't somehow broken the chain. */ - gcc_assert (head); - head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); - } - else /* head2 == head */ - { - gcc_assert (head2 == head); - /* Second operand is scalar. */ - head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); - } - - return head2; -} - - -/* Reverse a SS chain. */ - -gfc_ss * -gfc_reverse_ss (gfc_ss * ss) -{ - gfc_ss *next; - gfc_ss *head; - - gcc_assert (ss != NULL); - - head = gfc_ss_terminator; - while (ss != gfc_ss_terminator) - { - next = ss->next; - /* Check we didn't somehow break the chain. */ - gcc_assert (next != NULL); - ss->next = head; - head = ss; - ss = next; - } - - return (head); -} - - -/* Given an expression referring to a procedure, return the symbol of its - interface. We can't get the procedure symbol directly as we have to handle - the case of (deferred) type-bound procedures. */ - -gfc_symbol * -gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) -{ - gfc_symbol *sym; - gfc_ref *ref; - - if (procedure_ref == NULL) - return NULL; - - /* Normal procedure case. */ - sym = procedure_ref->symtree->n.sym; - - /* Typebound procedure case. */ - for (ref = procedure_ref->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer) - sym = ref->u.c.component->ts.interface; - else - sym = NULL; - } - - return sym; -} - - -/* Walk the arguments of an elemental function. - PROC_EXPR is used to check whether an argument is permitted to be absent. If - it is NULL, we don't do the check and the argument is assumed to be present. -*/ - -gfc_ss * -gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, - gfc_symbol *proc_ifc, gfc_ss_type type) -{ - gfc_formal_arglist *dummy_arg; - int scalar; - gfc_ss *head; - gfc_ss *tail; - gfc_ss *newss; - - head = gfc_ss_terminator; - tail = NULL; - - if (proc_ifc) - dummy_arg = gfc_sym_get_dummy_args (proc_ifc); - else - dummy_arg = NULL; - - scalar = 1; - for (; arg; arg = arg->next) - { - if (!arg->expr || arg->expr->expr_type == EXPR_NULL) - continue; - - newss = gfc_walk_subexpr (head, arg->expr); - if (newss == head) - { - /* Scalar argument. */ - gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); - newss = gfc_get_scalar_ss (head, arg->expr); - newss->info->type = type; - - } - else - scalar = 0; - - if (dummy_arg != NULL - && dummy_arg->sym->attr.optional - && arg->expr->expr_type == EXPR_VARIABLE - && (gfc_expr_attr (arg->expr).optional - || gfc_expr_attr (arg->expr).allocatable - || gfc_expr_attr (arg->expr).pointer)) - newss->info->can_be_null_ref = true; - - head = newss; - if (!tail) - { - tail = head; - while (tail->next != gfc_ss_terminator) - tail = tail->next; - } - - if (dummy_arg != NULL) - dummy_arg = dummy_arg->next; - } - - if (scalar) - { - /* If all the arguments are scalar we don't need the argument SS. */ - gfc_free_ss_chain (head); - /* Pass it back. */ - return ss; - } - - /* Add it onto the existing chain. */ - tail->next = ss; - return head; -} - - -/* Walk a function call. Scalar functions are passed back, and taken out of - scalarization loops. For elemental functions we walk their arguments. - The result of functions returning arrays is stored in a temporary outside - the loop, so that the function is only called once. Hence we do not need - to walk their arguments. */ - -static gfc_ss * -gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_intrinsic_sym *isym; - gfc_symbol *sym; - gfc_component *comp = NULL; - - isym = expr->value.function.isym; - - /* Handle intrinsic functions separately. */ - if (isym) - return gfc_walk_intrinsic_function (ss, expr, isym); - - sym = expr->value.function.esym; - if (!sym) - sym = expr->symtree->n.sym; - - /* A function that returns arrays. */ - comp = gfc_get_proc_ptr_comp (expr); - if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) - || (comp && comp->attr.dimension)) - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); - - /* Walk the parameters of an elemental function. For now we always pass - by reference. */ - if (sym->attr.elemental || (comp && comp->attr.elemental)) - return gfc_walk_elemental_function_args (ss, expr->value.function.actual, - gfc_get_proc_ifc_for_expr (expr), - GFC_SS_REFERENCE); - - /* Scalar functions are OK as these are evaluated outside the scalarization - loop. Pass back and let the caller deal with it. */ - return ss; -} - - -/* An array temporary is constructed for array constructors. */ - -static gfc_ss * -gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) -{ - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); -} - - -/* Walk an expression. Add walked expressions to the head of the SS chain. - A wholly scalar expression will not be added. */ - -gfc_ss * -gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - - switch (expr->expr_type) - { - case EXPR_VARIABLE: - head = gfc_walk_variable_expr (ss, expr); - return head; - - case EXPR_OP: - head = gfc_walk_op_expr (ss, expr); - return head; - - case EXPR_FUNCTION: - head = gfc_walk_function_expr (ss, expr); - return head; - - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_STRUCTURE: - /* Pass back and let the caller deal with it. */ - break; - - case EXPR_ARRAY: - head = gfc_walk_array_constructor (ss, expr); - return head; - - case EXPR_SUBSTRING: - /* Pass back and let the caller deal with it. */ - break; - - default: - internal_error ("bad expression type during walk (%d)", - expr->expr_type); - } - return ss; -} - - -/* Entry point for expression walking. - A return value equal to the passed chain means this is - a scalar expression. It is up to the caller to take whatever action is - necessary to translate these. */ - -gfc_ss * -gfc_walk_expr (gfc_expr * expr) -{ - gfc_ss *res; - - res = gfc_walk_subexpr (gfc_ss_terminator, expr); - return gfc_reverse_ss (res); -} |