aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/fortran/trans-array.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/gcc/fortran/trans-array.c')
-rw-r--r--gcc-4.8.1/gcc/fortran/trans-array.c8823
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);
-}