/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "coretypes.h"
#include "tree.h"
#include "gimple.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
+#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-const.h"
#include "dependency.h"
-static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
+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;
#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
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ 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;
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ 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));
}
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return build_fold_addr_expr (t);
+ t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+ field, NULL_TREE);
+ return gfc_build_addr_expr (NULL_TREE, t);
}
-tree
+static tree
gfc_conv_descriptor_offset (tree desc)
{
tree 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 (COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ 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)
{
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
}
static tree
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
+
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;
field = gfc_advance_chain (field, STRIDE_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
+ 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_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;
field = gfc_advance_chain (field, LBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
+ 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;
field = gfc_advance_chain (field, UBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
+ 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. */
}
+/* 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
/* Free a gfc_ss chain. */
-static void
+void
gfc_free_ss_chain (gfc_ss * ss)
{
gfc_ss *next;
switch (ss->type)
{
case GFC_SS_SECTION:
- for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ for (n = 0; n < ss->data.info.dimen; n++)
{
- if (ss->data.info.subscript[n])
- gfc_free_ss_chain (ss->data.info.subscript[n]);
+ if (ss->data.info.subscript[ss->data.info.dim[n]])
+ gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
}
break;
break;
}
- gfc_free (ss);
+ 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 *info;
+ int i;
+
+ ss = gfc_get_ss ();
+ ss->next = next;
+ ss->type = type;
+ ss->expr = expr;
+ info = &ss->data.info;
+ info->dimen = dimen;
+ for (i = 0; i < info->dimen; i++)
+ info->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;
+
+ ss = gfc_get_ss ();
+ ss->next = gfc_ss_terminator;
+ ss->type = GFC_SS_TEMP;
+ ss->string_length = string_length;
+ ss->data.temp.dimen = dimen;
+ ss->data.temp.type = type;
+
+ 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;
+
+ ss = gfc_get_ss ();
+ ss->next = next;
+ ss->type = GFC_SS_SCALAR;
+ ss->expr = expr;
+
+ return ss;
}
tree tmp;
if (as && as->type == AS_EXPLICIT)
- for (dim = 0; dim < se->loop->dimen; dim++)
+ for (n = 0; n < se->loop->dimen; n++)
{
- n = se->loop->order[dim];
+ dim = se->ss->data.info.dim[n];
+ gcc_assert (dim < as->rank);
+ gcc_assert (se->loop->dimen == as->rank);
if (se->loop->to[n] == NULL_TREE)
{
/* Evaluate the lower bound. */
upper = fold_convert (gfc_array_index_type, tmpse.expr);
/* Set the upper bound of the loop to UPPER - LOWER. */
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, upper, lower);
tmp = gfc_evaluate_now (tmp, &se->pre);
se->loop->to[n] = tmp;
}
{
/* Allocate the temporary. */
onstack = !dynamic && initial == NULL_TREE
- && gfc_can_put_var_on_stack (size);
+ && (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 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
- gfc_index_one_node);
+ 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");
- tmp = build_fold_addr_expr (tmp);
+ /* 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
gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
packed = gfc_create_var (build_pointer_type (tmp), "data");
- tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial);
+ 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 (initial);
+ 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
tmp = gfc_build_memcpy_call (packed, source_data, size);
gfc_add_expr_to_block (&do_copying, tmp);
- was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
- packed, source_data);
+ 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 ());
+ 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);
/* The offset is zero because we create temporaries with a zero
lower bound. */
- tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify (pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
if (dealloc && !onstack)
{
}
+/* 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
+ It is different from the loop dimension in the case of a transposed array.
+ */
+
+static int
+get_array_ref_dim (gfc_ss_info *info, int loop_dim)
+{
+ int n, array_dim, array_ref_dim;
+
+ array_ref_dim = 0;
+ array_dim = info->dim[loop_dim];
+
+ for (n = 0; n < info->dimen; n++)
+ if (n != loop_dim && info->dim[n] < array_dim)
+ array_ref_dim++;
+
+ return array_ref_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
tree eltype, tree initial, bool dynamic,
bool dealloc, bool callee_alloc, locus * where)
{
+ tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
tree type;
tree desc;
tree tmp;
tree nelem;
tree cond;
tree or_expr;
- int n;
- int dim;
+ int n, dim, tmp_dim;
+
+ memset (from, 0, sizeof (from));
+ memset (to, 0, sizeof (to));
gcc_assert (info->dimen > 0);
+ gcc_assert (loop->dimen == info->dimen);
if (gfc_option.warn_array_temp && where)
gfc_warning ("Creating array temporary at %L", where);
/* Set the lower bound to zero. */
- for (dim = 0; dim < info->dimen; dim++)
+ for (n = 0; n < loop->dimen; n++)
{
- n = loop->order[dim];
- if (n < loop->temp_dim)
- gcc_assert (integer_zerop (loop->from[n]));
- else
- {
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], loop->from[n]);
- loop->from[n] = gfc_index_zero_node;
- }
+ dim = info->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 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_array_ref_dim (info, n);
+ 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;
- info->dim[dim] = dim;
}
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
- GFC_ARRAY_UNKNOWN);
+ gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
+ GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
or_expr = NULL_TREE;
- /* If there is at least one null loop->to[n], it is a callee allocated
+ /* If there is at least one null loop->to[n], it is a callee allocated
array. */
- for (n = 0; n < info->dimen; n++)
+ for (n = 0; n < loop->dimen; n++)
if (loop->to[n] == NULL_TREE)
{
size = NULL_TREE;
break;
}
- for (n = 0; n < info->dimen; n++)
- {
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = info->dim[n];
+
if (size == NULL_TREE)
{
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
- tmp =
- fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
- gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
+ 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]));
loop->to[n] = tmp;
continue;
}
/* Store the stride and bound components in the descriptor. */
- tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify (pre, tmp, size);
+ gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
- tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify (pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+ gfc_index_zero_node);
- tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify (pre, tmp, loop->to[n]);
+ gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
+ to[n]);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- loop->to[n], gfc_index_one_node);
+ 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 (LE_EXPR, boolean_type_node, tmp,
- gfc_index_zero_node);
+ 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 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
+ or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, or_expr, cond);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size, tmp);
size = gfc_evaluate_now (size, pre);
}
{
/* 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 (COND_EXPR, gfc_array_index_type,
- or_expr, gfc_index_zero_node, size);
+ size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+ or_expr, gfc_index_zero_node, size);
nelem = size;
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size,
fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type))));
}
}
-/* Generate code to transpose array EXPR by creating a new descriptor
- in which the dimension specifications have been reversed. */
-
-void
-gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
-{
- tree dest, src, dest_index, src_index;
- gfc_loopinfo *loop;
- gfc_ss_info *dest_info, *src_info;
- gfc_ss *dest_ss, *src_ss;
- gfc_se src_se;
- int n;
-
- loop = se->loop;
-
- src_ss = gfc_walk_expr (expr);
- dest_ss = se->ss;
-
- src_info = &src_ss->data.info;
- dest_info = &dest_ss->data.info;
- gcc_assert (dest_info->dimen == 2);
- gcc_assert (src_info->dimen == 2);
-
- /* Get a descriptor for EXPR. */
- gfc_init_se (&src_se, NULL);
- gfc_conv_expr_descriptor (&src_se, expr, src_ss);
- gfc_add_block_to_block (&se->pre, &src_se.pre);
- gfc_add_block_to_block (&se->post, &src_se.post);
- src = src_se.expr;
-
- /* Allocate a new descriptor for the return value. */
- dest = gfc_create_var (TREE_TYPE (src), "atmp");
- dest_info->descriptor = dest;
- se->expr = dest;
-
- /* Copy across the dtype field. */
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_dtype (dest),
- gfc_conv_descriptor_dtype (src));
-
- /* Copy the dimension information, renumbering dimension 1 to 0 and
- 0 to 1. */
- for (n = 0; n < 2; n++)
- {
- dest_info->delta[n] = gfc_index_zero_node;
- dest_info->start[n] = gfc_index_zero_node;
- dest_info->end[n] = gfc_index_zero_node;
- dest_info->stride[n] = gfc_index_one_node;
- dest_info->dim[n] = n;
-
- dest_index = gfc_rank_cst[n];
- src_index = gfc_rank_cst[1 - n];
-
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_stride (dest, dest_index),
- gfc_conv_descriptor_stride (src, src_index));
-
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_lbound (dest, dest_index),
- gfc_conv_descriptor_lbound (src, src_index));
-
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_ubound (src, src_index));
-
- if (!loop->to[n])
- {
- gcc_assert (integer_zerop (loop->from[n]));
- loop->to[n] =
- fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_lbound (dest, dest_index));
- }
- }
-
- /* Copy the data pointer. */
- dest_info->data = gfc_conv_descriptor_data_get (src);
- gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
-
- /* Copy the offset. This is not changed by transposition; the top-left
- element is still at the same offset as before, except where the loop
- starts at zero. */
- if (!integer_zerop (loop->from[0]))
- dest_info->offset = gfc_conv_descriptor_offset (src);
- else
- dest_info->offset = gfc_index_zero_node;
-
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_offset (dest),
- dest_info->offset);
-
- if (dest_info->dimen > loop->temp_dim)
- loop->temp_dim = dest_info->dimen;
-}
-
-
/* Return the number of iterations in a loop that starts at START,
ends at END, and has step STEP. */
tree type;
type = TREE_TYPE (step);
- tmp = fold_build2 (MINUS_EXPR, type, end, start);
- tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
- tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
- tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
+ 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);
}
if (integer_zerop (extra))
return;
- ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
/* Add EXTRA to the upper bound. */
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
- gfc_add_modify (pblock, ubound, tmp);
+ 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 (PLUS_EXPR, gfc_array_index_type,
- ubound, gfc_index_one_node);
- arg1 = fold_build2 (MULT_EXPR, size_type_node,
- fold_convert (size_type_node, tmp),
- fold_convert (size_type_node, size));
+ 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);
of array constructor C. */
static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
+ gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_init (val);
dynamic = false;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
gfc_conv_expr (se, expr);
/* Store the value. */
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
+ 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)
esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
esize = fold_convert (gfc_charlen_type_node, esize);
- esize = fold_build2 (TRUNC_DIV_EXPR, 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_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
se->string_length, se->expr, expr->ts.kind);
}
- if (flag_bounds_check && !typespec_chararray_ctor)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
{
if (first_len)
{
{
/* Verify that all constructor elements are of the same
length. */
- tree cond = fold_build2 (NE_EXPR, boolean_type_node,
- first_len_val, se->string_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",
{
tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
gfc_index_one_node);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
}
/* Grow the constructed array by SIZE elements. */
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- *poffset, gfc_index_one_node);
+ 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. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor * c,
+ tree desc, gfc_constructor_base base,
tree * poffset, tree * offsetvar,
bool dynamic)
{
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; c = c->next)
+ 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 = c->iterator->var->symtree->n.sym;
+ tree 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)
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
- p = p->next;
+ p = gfc_constructor_next (p);
n++;
}
if (n < 4)
gfc_trans_array_ctor_element (&body, desc, *poffset,
&se, c->expr);
- *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- *poffset, gfc_index_one_node);
+ *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. */
- tree list;
+ VEC(constructor_elt,gc) *v = NULL;
tree init;
tree bound;
tree tmptype;
+ HOST_WIDE_INT idx = 0;
p = c;
- list = NULL_TREE;
/* 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. */
- if (p->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (type))
+ else if (POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr
(gfc_get_pchar_type (p->expr->ts.kind),
se.expr);
- list = tree_cons (NULL_TREE, se.expr, list);
+ CONSTRUCTOR_APPEND_ELT (v,
+ build_int_cst (gfc_array_index_type,
+ idx++),
+ se.expr);
c = p;
- p = p->next;
+ p = gfc_constructor_next (p);
}
- bound = build_int_cst (NULL_TREE, n - 1);
+ 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_from_list (tmptype, nreverse (list));
+ init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
tmp = gfc_build_array_ref (tmp, *poffset, NULL);
- tmp = build_fold_addr_expr (tmp);
- init = build_fold_addr_expr (init);
+ 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 (NULL_TREE, n * size);
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
- tmp, init, bound);
+ 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 (PLUS_EXPR, gfc_array_index_type,
- *poffset,
+ *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))
else
{
/* Build the implied do-loop. */
+ stmtblock_t implied_do_block;
tree cond;
tree end;
tree step;
- tree loopvar;
tree exit_label;
tree loopbody;
tree tmp2;
- tree tmp_loopvar;
loopbody = gfc_finish_block (&body);
- if (c->iterator->var->symtree->n.sym->backend_decl)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, c->iterator->var);
- gfc_add_block_to_block (pblock, &se.pre);
- loopvar = se.expr;
- }
- else
- {
- /* If the iterator appears in a specification expression in
- an interface mapping, we need to make a temp for the loop
- variable because it is not declared locally. */
- loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
- loopvar = gfc_create_var (loopvar, "loopvar");
- }
-
- /* Make a temporary, store the current value in that
- and return it, once the loop is done. */
- tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
- gfc_add_modify (pblock, tmp_loopvar, loopvar);
+ /* 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_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->start);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, loopvar, se.expr);
+ gfc_add_block_to_block (&implied_do_block, &se.pre);
+ gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
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_add_block_to_block (&implied_do_block, &se.pre);
+ end = gfc_evaluate_now (se.expr, &implied_do_block);
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);
+ gfc_add_block_to_block (&implied_do_block, &se.pre);
+ step = gfc_evaluate_now (se.expr, &implied_do_block);
/* If this array expands dynamically, and the number of iterations
is not constant, we won't have allocated space for the static
if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
{
/* Get the number of iterations. */
- tmp = gfc_get_iteration_count (loopvar, end, step);
+ 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 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
- gfc_grow_array (pblock, desc, tmp);
+ 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. */
/* Generate the exit condition. Depending on the sign of
the step variable we have to generate the correct
comparison. */
- tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
- build_int_cst (TREE_TYPE (step), 0));
- cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
- fold_build2 (GT_EXPR, boolean_type_node,
- loopvar, end),
- fold_build2 (LT_EXPR, boolean_type_node,
- loopvar, end));
+ 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 ());
+ 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 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
- gfc_add_modify (&body, loopvar, tmp);
+ 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 (pblock, 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 (pblock, tmp);
+ gfc_add_expr_to_block (&implied_do_block, tmp);
+
+ /* Finishe the implied-do loop. */
+ tmp = gfc_finish_block(&implied_do_block);
+ gfc_add_expr_to_block(pblock, tmp);
- /* Restore the original value of the loop counter. */
- gfc_add_modify (pblock, loopvar, tmp_loopvar);
+ 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
+ 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;
+ gfc_ss *ss;
+
+ /* 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. */
+ ss = gfc_walk_expr (e);
+ gfc_init_se (&se, NULL);
+
+ /* No function call, in case of side effects. */
+ se.no_function_call = 1;
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr (&se, e);
+ else
+ gfc_conv_expr_descriptor (&se, e, ss);
+
+ /* 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 (gfc_expr * expr, tree * len)
+get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
{
gfc_ref *ref;
gfc_typespec *ts;
case REF_SUBSTRING:
if (ref->u.ss.start->expr_type != EXPR_CONSTANT
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
- break;
+ {
+ /* 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);
return;
default:
- /* TODO: Substrings are tricky because we can't evaluate the
- expression more than once. For now we just give up, and hope
- we can figure it out elsewhere. */
- return;
+ gcc_unreachable ();
}
}
- *len = ts->cl->backend_decl;
-}
-
-
-/* A catch-all to obtain the string length for anything that is not a
- constant, array or variable. */
-static void
-get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
-{
- gfc_se se;
- gfc_ss *ss;
-
- /* Don't bother if we already know the length is a constant. */
- if (*len && INTEGER_CST_P (*len))
- return;
-
- if (!e->ref && e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
- {
- /* This is easy. */
- gfc_conv_const_charlen (e->ts.cl);
- *len = e->ts.cl->backend_decl;
- }
- else
- {
- /* Otherwise, be brutal even if inefficient. */
- ss = gfc_walk_expr (e);
- gfc_init_se (&se, NULL);
-
- /* No function call, in case of side effects. */
- se.no_function_call = 1;
- if (ss == gfc_ss_terminator)
- gfc_conv_expr (&se, e);
- else
- gfc_conv_expr_descriptor (&se, e, ss);
-
- /* 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.cl->backend_decl = *len;
- }
+ *len = ts->u.cl->backend_decl;
}
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
+ gfc_constructor *c;
bool is_const;
-
+
is_const = TRUE;
- if (c == NULL)
+ if (gfc_constructor_first (base) == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
/* 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 && is_const; c = c->next)
+ for (c = gfc_constructor_first (base);
+ c && is_const; c = gfc_constructor_next (c))
{
switch (c->expr->expr_type)
{
case EXPR_VARIABLE:
is_const = false;
if (len)
- get_array_ctor_var_strlen (c->expr, len);
+ get_array_ctor_var_strlen (block, c->expr, len);
break;
default:
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor * c)
+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 = c->next;
+ c = gfc_constructor_next (c);
nelem++;
}
return nelem;
tree
gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
- tree tmptype, list, init, tmp;
+ tree tmptype, init, tmp;
HOST_WIDE_INT nelem;
gfc_constructor *c;
gfc_array_spec as;
gfc_se se;
int i;
+ VEC(constructor_elt,gc) *v = NULL;
/* First traverse the constructor list, converting the constants
to tree to build an initializer. */
nelem = 0;
- list = NULL_TREE;
- c = expr->value.constructor;
+ 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 && POINTER_TYPE_P (type))
+ 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);
- list = tree_cons (NULL_TREE, se.expr, list);
- c = c->next;
+ CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
+ se.expr);
+ c = gfc_constructor_next (c);
nelem++;
}
as.type = AS_EXPLICIT;
if (!expr->shape)
{
- as.lower[0] = gfc_int_expr (0);
- as.upper[0] = gfc_int_expr (nelem - 1);
+ 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_int_expr (0);
- as.upper[i] = gfc_int_expr (tmp - 1);
+ 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);
+ 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_from_list (tmptype, nreverse (list));
+ init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
info = &ss->data.info;
info->descriptor = tmp;
- info->data = build_fold_addr_expr (tmp);
+ info->data = gfc_build_addr_expr (NULL_TREE, tmp);
info->offset = gfc_index_zero_node;
for (i = 0; i < info->dimen; i++)
info->start[i] = gfc_index_zero_node;
info->end[i] = gfc_index_zero_node;
info->stride[i] = gfc_index_one_node;
- info->dim[i] = i;
}
if (info->dimen > loop->temp_dim)
/* Only allow nonzero "from" in one-dimensional arrays. */
if (loop->dimen != 1)
return NULL_TREE;
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[i], loop->from[i]);
+ 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 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ 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 void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
- gfc_constructor *c;
+ gfc_constructor_base c;
tree offset;
tree offsetvar;
tree desc;
tree type;
+ tree tmp;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
/* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
typespec was given for the array constructor. */
- typespec_chararray_ctor = (ss->expr->ts.cl
- && ss->expr->ts.cl->length_from_typespec);
+ typespec_chararray_ctor = (ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length_from_typespec);
- if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
- && !typespec_chararray_ctor)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
{
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true;
}
- ss->data.info.dimen = loop->dimen;
+ gcc_assert (ss->data.info.dimen == loop->dimen);
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
/* 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 && ss->expr->ts.cl->length
- && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
+ && ss->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, ss->expr->ts.cl->length,
+ gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
gfc_charlen_type_node);
ss->string_length = length_se.expr;
gfc_add_block_to_block (&loop->pre, &length_se.pre);
and not end up here. */
gcc_assert (ss->string_length);
- ss->expr->ts.cl->backend_decl = ss->string_length;
+ ss->expr->ts.u.cl->backend_decl = ss->string_length;
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
loop->from[n] = gfc_index_zero_node;
loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
gfc_index_integer_kind);
- loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], gfc_index_one_node);
+ loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], gfc_index_one_node);
}
}
}
}
+ if (TREE_CODE (loop->to[0]) == VAR_DECL)
+ dynamic = true;
+
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
type, NULL_TREE, dynamic, true, false, where);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
- loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offsetvar, gfc_index_one_node);
+ tmp = gfc_evaluate_now (tmp, &loop->pre);
+ gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
+ if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
+ gfc_add_modify (&loop->pre, loop->to[0], tmp);
+ else
+ loop->to[0] = 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 (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
gcc_unreachable ();
}
gfc_init_se (&se, NULL);
desc = info->subscript[dim]->data.info.descriptor;
zero = gfc_rank_cst[0];
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, zero),
- gfc_conv_descriptor_lbound (desc, zero));
+ 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, &loop->pre);
loop->to[n] = tmp;
}
break;
case GFC_SS_REFERENCE:
- /* Scalar reference. Evaluate this now. */
+ /* Scalar argument to elemental procedure. Evaluate this
+ now. */
gfc_init_se (&se, NULL);
- gfc_conv_expr_reference (&se, ss->expr);
+ gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
case GFC_SS_CONSTRUCTOR:
if (ss->expr->ts.type == BT_CHARACTER
&& ss->string_length == NULL
- && ss->expr->ts.cl
- && ss->expr->ts.cl->length)
+ && ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
+ gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
gfc_charlen_type_node);
ss->string_length = se.expr;
gfc_add_block_to_block (&loop->pre, &se.pre);
tmp = gfc_conv_array_offset (se.expr);
ss->data.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. */
+ ss->data.info.saved_offset = ss->data.info.offset;
}
}
gfc_init_block (&loop->pre);
gfc_init_block (&loop->post);
- /* Initially scalarize in order. */
+ /* Initially scalarize in order and default to no loop reversal. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
- loop->order[n] = n;
+ {
+ loop->order[n] = n;
+ loop->reverse[n] = GFC_INHIBIT_REVERSE;
+ }
loop->ss = gfc_ss_terminator;
}
else
{
/* Descriptorless arrays. */
- return build_fold_addr_expr (descriptor);
+ return gfc_build_addr_expr (NULL_TREE, descriptor);
}
}
else
if (GFC_ARRAY_TYPE_P (type))
return GFC_TYPE_ARRAY_OFFSET (type);
else
- return gfc_conv_descriptor_offset (descriptor);
+ return gfc_conv_descriptor_offset_get (descriptor);
}
if (tmp != NULL_TREE)
return tmp;
- tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
if (tmp != NULL_TREE)
return tmp;
- tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
return gfc_index_zero_node;
- tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
locus * where, bool check_upper)
{
tree fault;
- tree tmp;
+ tree tmp_lo, tmp_up;
char *msg;
const char * name = NULL;
- if (!flag_bounds_check)
+ if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
return index;
index = gfc_evaluate_now (index, &se->pre);
&& se->loop->ss->loop_chain->expr->symtree)
name = se->loop->ss->loop_chain->expr->symtree->name;
- if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
- && se->loop->ss->loop_chain->expr->symtree)
- name = se->loop->ss->loop_chain->expr->symtree->name;
-
if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
{
if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
name = "unnamed constant";
}
- /* Check lower bound. */
- tmp = gfc_conv_array_lbound (descriptor, n);
- fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
- if (name)
- asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
- "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
- else
- asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
- gfc_msg_fault, n+1);
- 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));
- gfc_free (msg);
-
- /* Check upper bound. */
+ 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 = gfc_conv_array_ubound (descriptor, n);
- fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
+ 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, "%s for array '%s', upper bound of dimension %d "
- " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "below lower bound of %%ld", n+1, name);
else
- asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
- gfc_msg_fault, n+1);
+ 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));
- gfc_free (msg);
+ 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. */
+ dimensions. Single element references are processed separately.
+ DIM is the array dimension, I is the loop dimension. */
static tree
gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
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]
index = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ ar->as->type != AS_ASSUMED_SIZE
+ || dim < ar->dimen - 1);
break;
case DIMEN_VECTOR:
desc = info->subscript[dim]->data.info.descriptor;
/* Get a zero-based index into the vector. */
- index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- se->loop->loopvar[i], se->loop->from[i]);
+ 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 (MULT_EXPR, gfc_array_index_type,
- index, gfc_conv_array_stride (desc, 0));
+ 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 (gfc_conv_array_data (desc));
+ 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 = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ 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. */
+ /* Multiply the loop variable by the stride and delta. */
index = se->loop->loopvar[i];
- if (!integer_onep (info->stride[i]))
- index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
- info->stride[i]);
- if (!integer_zerop (info->delta[i]))
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
- info->delta[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:
/* Temporary array or derived type component. */
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
- if (!integer_zerop (info->delta[i]))
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- index, info->delta[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->type == GFC_SS_FUNCTION
+ && se->ss->expr
+ && se->ss->expr->symtree
+ && se->ss->expr->symtree->n.sym->result
+ && se->ss->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 (MULT_EXPR, gfc_array_index_type, index, stride);
+ index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ index, stride);
return index;
}
/* Add the offset for this dimension to the stored offset for all other
dimensions. */
if (!integer_zerop (info->offset))
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
+ index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ index, info->offset);
if (se->ss->expr && is_subref_array (se->ss->expr))
decl = se->ss->expr->symtree->n.sym->backend_decl;
- tmp = build_fold_indirect_ref (info->data);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ info->data);
se->expr = gfc_build_array_ref (tmp, index, decl);
}
{
se->string_length = se->ss->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;
+ }
+}
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
locus * where)
{
int n;
- tree index;
+ 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)
return;
}
- index = gfc_index_zero_node;
+ 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. */
- for (n = 0; n < ar->dimen; n++)
+ /* 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 (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check array bounds. */
tree cond;
/* Lower bound. */
tmp = gfc_conv_array_lbound (se->expr, n);
- cond = fold_build2 (LT_EXPR, boolean_type_node,
- indexse.expr, tmp);
- asprintf (&msg, "%s for array '%s', "
- "lower bound of dimension %d exceeded (%%ld < %%ld)",
- gfc_msg_fault, sym->name, n+1);
+ 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));
- gfc_free (msg);
+ 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 && !ar->as->cp_was_assumed))
+ if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
{
tmp = gfc_conv_array_ubound (se->expr, n);
- cond = fold_build2 (GT_EXPR, boolean_type_node,
- indexse.expr, tmp);
- asprintf (&msg, "%s for array '%s', "
- "upper bound of dimension %d exceeded (%%ld > %%ld)",
- gfc_msg_fault, sym->name, n+1);
+ 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));
- gfc_free (msg);
+ free (msg);
}
}
/* Multiply the index by the stride. */
stride = gfc_conv_array_stride (se->expr, n);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
- stride);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ indexse.expr, stride);
/* And add it to the total. */
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
+ add_to_offset (&cst_offset, &offset, tmp);
}
- tmp = gfc_conv_array_offset (se->expr);
- if (!integer_zerop (tmp))
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
+ if (!integer_zerop (cst_offset))
+ offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, cst_offset);
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
+ se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
}
gfc_ss_info *info;
gfc_ss *ss;
gfc_se se;
+ gfc_array_ref *ar;
int i;
/* This code will be executed before entering the scalarization loop
if (dim >= info->dimen)
continue;
+ if (info->ref)
+ {
+ ar = &info->ref->u.ar;
+ i = loop->order[dim + 1];
+ }
+ else
+ {
+ ar = NULL;
+ i = dim + 1;
+ }
+
+
if (dim == info->dimen - 1)
{
+ i = loop->order[0];
+ /* For the time being, the innermost loop is unconditionally on
+ the first dimension of the scalarization loop. */
+ gcc_assert (i == 0);
+ stride = gfc_conv_array_stride (info->descriptor, info->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 < info->ref->u.ar.dimen; i++)
+ for (i = 0; i < ar->dimen; i++)
{
- if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+ if (ar->dimen_type[i] != DIMEN_ELEMENT)
continue;
gfc_init_se (&se, NULL);
se.expr = info->descriptor;
stride = gfc_conv_array_stride (info->descriptor, i);
index = gfc_conv_array_index_offset (&se, info, i, -1,
- &info->ref->u.ar,
- stride);
+ ar, stride);
gfc_add_block_to_block (pblock, &se.pre);
- info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- info->offset, index);
+ info->offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ info->offset, index);
info->offset = gfc_evaluate_now (info->offset, pblock);
}
-
- i = loop->order[0];
- stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
}
- else
- stride = gfc_conv_array_stride (info->descriptor, 0);
-
- /* 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);
}
else
{
/* Add the offset for the previous loop dimension. */
- gfc_array_ref *ar;
-
- if (info->ref)
- {
- ar = &info->ref->u.ar;
- i = loop->order[dim + 1];
- }
- else
- {
- ar = NULL;
- i = dim + 1;
- }
-
gfc_init_se (&se, NULL);
se.loop = loop;
se.expr = info->descriptor;
index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
ar, stride);
gfc_add_block_to_block (pblock, &se.pre);
- info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- info->offset, index);
+ info->offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, info->offset,
+ index);
info->offset = gfc_evaluate_now (info->offset, pblock);
}
/* Generates the actual loop code for a scalarization loop. */
-static void
+void
gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
stmtblock_t * pbody)
{
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);
+ loopbody = gfc_finish_block (pbody);
- /* Initialize the loopvar. */
- gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
+ if (reverse_loop)
+ {
+ tmp = loop->from[n];
+ loop->from[n] = loop->to[n];
+ loop->to[n] = tmp;
+ }
- exit_label = gfc_build_label_decl (NULL_TREE);
+ /* Initialize the loopvar. */
+ if (loop->loopvar[n] != loop->from[n])
+ gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
- /* Generate the loop body. */
- gfc_init_block (&block);
+ exit_label = gfc_build_label_decl (NULL_TREE);
- /* The exit condition. */
- cond = fold_build2 (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 ());
- gfc_add_expr_to_block (&block, tmp);
+ /* Generate the loop body. */
+ gfc_init_block (&block);
- /* The main body. */
- gfc_add_expr_to_block (&block, loopbody);
+ /* 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);
- /* Increment the loopvar. */
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- loop->loopvar[n], gfc_index_one_node);
- gfc_add_modify (&block, loop->loopvar[n], tmp);
+ /* The main body. */
+ gfc_add_expr_to_block (&block, loopbody);
- /* Build the loop. */
- tmp = gfc_finish_block (&block);
- tmp = build1_v (LOOP_EXPR, tmp);
- gfc_add_expr_to_block (&loop->code[n], tmp);
+ /* 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);
+ }
- /* Add the exit label. */
- tmp = build1_v (LABEL_EXPR, exit_label);
- gfc_add_expr_to_block (&loop->code[n], tmp);
}
}
-/* Calculate the upper bound of an array section. */
+/* 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 tree
-gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
+static void
+evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
+ tree desc, int dim, bool lbound)
{
- int dim;
- gfc_expr *end;
- tree desc;
- tree bound;
gfc_se se;
- gfc_ss_info *info;
-
- gcc_assert (ss->type == GFC_SS_SECTION);
-
- info = &ss->data.info;
- dim = info->dim[n];
+ gfc_expr * input_val = values[dim];
+ tree *output = &bounds[dim];
- if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- /* We'll calculate the upper bound once we have access to the
- vector's descriptor. */
- return NULL;
- gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
- desc = info->descriptor;
- end = info->ref->u.ar.end[dim];
-
- if (end)
+ if (input_val)
{
- /* The upper bound was specified. */
+ /* Specified section bound. */
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, end, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- bound = se.expr;
+ gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
+ gfc_add_block_to_block (block, &se.pre);
+ *output = se.expr;
}
else
{
- /* No upper bound was specified, so use the bound of the array. */
- bound = gfc_conv_array_ubound (desc, dim);
+ /* 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);
}
-
- return bound;
+ *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 n)
+gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
{
- gfc_expr *start;
- gfc_expr *end;
- gfc_expr *stride;
+ gfc_expr *stride = NULL;
tree desc;
gfc_se se;
gfc_ss_info *info;
- int dim;
+ gfc_array_ref *ar;
gcc_assert (ss->type == GFC_SS_SECTION);
info = &ss->data.info;
- dim = info->dim[n];
+ ar = &info->ref->u.ar;
- if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ if (ar->dimen_type[dim] == DIMEN_VECTOR)
{
/* We use a zero-based index to access the vector. */
- info->start[n] = gfc_index_zero_node;
- info->end[n] = gfc_index_zero_node;
- info->stride[n] = gfc_index_one_node;
+ info->start[dim] = gfc_index_zero_node;
+ info->end[dim] = NULL;
+ info->stride[dim] = gfc_index_one_node;
return;
}
- gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+ gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
+ || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
desc = info->descriptor;
- start = info->ref->u.ar.start[dim];
- end = info->ref->u.ar.end[dim];
- stride = info->ref->u.ar.stride[dim];
+ stride = ar->stride[dim];
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
- if (start)
- {
- /* Specified section start. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, start, gfc_array_index_type);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- info->start[n] = se.expr;
- }
- else
- {
- /* No lower bound specified so use the bound of the array. */
- info->start[n] = gfc_conv_array_lbound (desc, dim);
- }
- info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
+ 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. */
- if (end)
- {
- /* Specified section start. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, end, gfc_array_index_type);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- info->end[n] = se.expr;
- }
- else
- {
- /* No upper bound specified so use the bound of the array. */
- info->end[n] = gfc_conv_array_ubound (desc, dim);
- }
- info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
+ evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
/* Calculate the stride. */
if (stride == NULL)
- info->stride[n] = gfc_index_one_node;
+ 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[n] = gfc_evaluate_now (se.expr, &loop->pre);
+ info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
}
}
loop->dimen = 0;
/* Determine the rank of the loop. */
- for (ss = loop->ss;
- ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
+ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
switch (ss->type)
{
case GFC_SS_FUNCTION:
case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen;
- break;
+ goto done;
/* As usual, lbound and ubound are exceptions!. */
case GFC_SS_INTRINSIC:
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_LCOBOUND:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
loop->dimen = ss->data.info.dimen;
+ goto done;
default:
break;
/* We should have determined the rank of the expression by now. If
not, that's bad news. */
- gcc_assert (loop->dimen != 0);
+ gcc_unreachable ();
+done:
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
for (n = 0; n < ss->data.info.dimen; n++)
- gfc_conv_section_startstride (loop, ss, n);
+ gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
break;
case GFC_SS_INTRINSIC:
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_LCOBOUND:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
break;
+
default:
continue;
}
}
/* The rest is just runtime bound checking. */
- if (flag_bounds_check)
+ 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;
+ tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
gfc_ss_info *info;
char *msg;
int dim;
if (ss->type != GFC_SS_SECTION)
continue;
+ /* Catch allocatable lhs in f2003. */
+ if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
+ continue;
+
gfc_start_block (&inner);
/* TODO: range checking for mapped dimensions. */
continue;
if (dim == info->ref->u.ar.dimen - 1
- && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
- || info->ref->u.ar.as->cp_was_assumed))
+ && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
check_upper = false;
else
check_upper = true;
/* Zero stride is not allowed. */
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
- gfc_index_zero_node);
+ 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'", info->dim[n]+1,
- ss->expr->symtree->name);
+ "of array '%s'", dim + 1, ss->expr->symtree->name);
gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg);
- gfc_free (msg);
+ free (msg);
desc = ss->data.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. */
+ 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[n];
+ 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 (GT_EXPR, boolean_type_node,
- info->stride[n], gfc_index_zero_node);
- tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
- end);
- stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- stride_pos, tmp);
-
- stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
- info->stride[n], gfc_index_zero_node);
- tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
- end);
- stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- stride_neg, tmp);
- non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- stride_pos, stride_neg);
+ 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. */
- tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
- lbound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded (%%ld < %%ld)", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (true, false, tmp, &inner,
- &ss->expr->where, msg,
- fold_convert (long_integer_type_node,
- info->start[n]),
- fold_convert (long_integer_type_node,
- lbound));
- gfc_free (msg);
-
+ 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 (GT_EXPR, boolean_type_node,
- info->start[n], ubound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, upper bound of dimension %d of array "
- "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
+ 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, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, 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,
+ &ss->expr->where, 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, ss->expr->symtree->name);
gfc_trans_runtime_check (true, false, tmp, &inner,
- &ss->expr->where, msg,
- fold_convert (long_integer_type_node, info->start[n]),
- fold_convert (long_integer_type_node, ubound));
- gfc_free (msg);
+ &ss->expr->where, 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. */
- tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
- info->start[n]);
- tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
- info->stride[n]);
- tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
- tmp2);
-
- tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded (%%ld < %%ld)", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (true, false, tmp, &inner,
- &ss->expr->where, msg,
- fold_convert (long_integer_type_node,
- tmp2),
- fold_convert (long_integer_type_node,
- lbound));
- gfc_free (msg);
+ 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)
{
- tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, upper bound of dimension %d of array "
- "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (true, false, tmp, &inner,
- &ss->expr->where, msg,
- fold_convert (long_integer_type_node, tmp2),
- fold_convert (long_integer_type_node, ubound));
- gfc_free (msg);
+ 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, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp2, &inner,
+ &ss->expr->where, 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,
+ &ss->expr->where, 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, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp2, &inner,
+ &ss->expr->where, 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 (MINUS_EXPR, gfc_array_index_type, end,
- info->start[n]);
- tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
- info->stride[n]);
- tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
- build_int_cst (gfc_array_index_type, 0));
+ 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. */
+ others against this. */
if (size[n])
{
- tree tmp3;
+ 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, ss->expr->symtree->name);
- tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
- asprintf (&msg, "%s, size mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
- info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (true, false, tmp3, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
- gfc_free (msg);
+
+ free (msg);
}
else
size[n] = gfc_evaluate_now (tmp, &inner);
|| ss->expr->symtree->n.sym->attr.not_always_present)
tmp = build3_v (COND_EXPR,
gfc_conv_expr_present (ss->expr->symtree->n.sym),
- tmp, build_empty_stmt ());
+ tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
}
+/* 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. */
gfc_ref *rref;
gfc_symbol *lsym;
gfc_symbol *rsym;
+ bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
lsym = lss->expr->symtree->n.sym;
rsym = rss->expr->symtree->n.sym;
- if (gfc_symbols_could_alias (lsym, rsym))
+
+ 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
- && lsym->ts.type != BT_DERIVED)
+ 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
if (lref->type != REF_COMPONENT)
continue;
- if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
+ 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 = rss->expr->ref; rref != rss->data.info.ref;
rref = rref->next)
{
if (rref->type != REF_COMPONENT)
continue;
- if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
+ 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 = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
{
if (rref->type != REF_COMPONENT)
break;
- if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
+ 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;
gfc_ss *ss;
gfc_ref *lref;
gfc_ref *rref;
- gfc_ref *aref;
int nDepend = 0;
- int temp_dim = 0;
+ int i, j;
loop->temp_ss = NULL;
- aref = dest->data.info.ref;
- temp_dim = 0;
for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
{
lref = dest->expr->ref;
rref = ss->expr->ref;
- nDepend = gfc_dep_resolver (lref, rref);
+ nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
+
if (nDepend == 1)
break;
+
+ for (i = 0; i < dest->data.info.dimen; i++)
+ for (j = 0; j < ss->data.info.dimen; j++)
+ if (i != j
+ && dest->data.info.dim[i] == ss->data.info.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)
if (depends[n])
loop->order[dim++] = n;
}
- temp_dim = dim;
for (n = 0; n < loop->dimen; n++)
{
if (! depends[n])
}
}
+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_ss ();
- loop->temp_ss->type = GFC_SS_TEMP;
- loop->temp_ss->data.temp.type = base_type;
- loop->temp_ss->string_length = dest->string_length;
- loop->temp_ss->data.temp.dimen = loop->dimen;
- loop->temp_ss->next = gfc_ss_terminator;
+ loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
+ loop->dimen);
gfc_add_ss_to_loop (loop, loop->temp_ss);
}
else
void
gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
{
- int n;
- int dim;
+ int n, dim, spec_dim;
gfc_ss_info *info;
gfc_ss_info *specinfo;
gfc_ss *ss;
tree tmp;
- tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
- gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
loopspec[n] = NULL;
dynamic[n] = false;
/* 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. */
+ loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
+ if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
+ continue;
+
+ info = &ss->data.info;
+ dim = info->dim[n];
+
+ if (loopspec[n] != NULL)
+ {
+ specinfo = &loopspec[n]->data.info;
+ spec_dim = specinfo->dim[n];
+ }
+ else
+ {
+ /* Silence unitialized warnings. */
+ specinfo = NULL;
+ spec_dim = 0;
+ }
+
if (ss->shape)
{
+ gcc_assert (ss->shape[dim]);
/* The frontend has worked out the size for us. */
- if (!loopspec[n] || !loopspec[n]->shape
- || !integer_zerop (loopspec[n]->data.info.start[n]))
+ if (!loopspec[n]
+ || !loopspec[n]->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. */
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. */
- c = ss->expr->value.constructor;
- dynamic[n] = gfc_get_array_constructor_size (&i, c);
+ base = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, base);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
/* TODO: Pick the best bound if we have a choice between a
function and something else. */
- if (ss->type == GFC_SS_FUNCTION)
- {
- loopspec[n] = ss;
- continue;
- }
+ if (ss->type == GFC_SS_FUNCTION)
+ {
+ loopspec[n] = ss;
+ continue;
+ }
- if (ss->type != GFC_SS_SECTION)
+ /* 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])
- specinfo = &loopspec[n]->data.info;
- else
- specinfo = NULL;
- info = &ss->data.info;
+ if (ss->type != GFC_SS_SECTION)
+ continue;
- if (!specinfo)
+ if (!loopspec[n])
loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
doesn't need realloc
known lower bound
known upper bound
*/
- else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+ else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+ || n >= loop->dimen)
loopspec[n] = ss;
- else if (integer_onep (info->stride[n])
- && !integer_onep (specinfo->stride[n]))
+ else if (integer_onep (info->stride[dim])
+ && !integer_onep (specinfo->stride[spec_dim]))
loopspec[n] = ss;
- else if (INTEGER_CST_P (info->stride[n])
- && !INTEGER_CST_P (specinfo->stride[n]))
+ 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[n])
- && !INTEGER_CST_P (specinfo->start[n]))
+ else if (INTEGER_CST_P (info->start[dim])
+ && !INTEGER_CST_P (specinfo->start[spec_dim]))
loopspec[n] = ss;
/* We don't work out the upper bound.
else if (INTEGER_CST_P (info->finish[n])
gcc_assert (loopspec[n]);
info = &loopspec[n]->data.info;
+ dim = info->dim[n];
/* Set the extents of this range. */
cshape = loopspec[n]->shape;
- if (cshape && INTEGER_CST_P (info->start[n])
- && INTEGER_CST_P (info->stride[n]))
+ if (cshape && INTEGER_CST_P (info->start[dim])
+ && INTEGER_CST_P (info->stride[dim]))
{
- loop->from[n] = info->start[n];
- mpz_set (i, cshape[n]);
+ loop->from[n] = info->start[dim];
+ mpz_set (i, cshape[get_array_ref_dim (info, 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[n]))
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- tmp, info->stride[n]);
- loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- loop->from[n], tmp);
+ 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[n];
+ loop->from[n] = info->start[dim];
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
break;
case GFC_SS_SECTION:
- loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
- &loop->pre);
+ /* 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:
+ case GFC_SS_FUNCTION:
/* The loop bound will be set when we generate the call. */
- gcc_assert (loop->to[n] == NULL_TREE);
- break;
+ gcc_assert (loop->to[n] == NULL_TREE);
+ break;
default:
gcc_unreachable ();
}
/* Transform everything so we have a simple incrementing variable. */
- if (integer_onep (info->stride[n]))
- info->delta[n] = gfc_index_zero_node;
- else
+ if (n < loop->dimen && integer_onep (info->stride[dim]))
+ info->delta[dim] = gfc_index_zero_node;
+ else if (n < loop->dimen)
{
/* Set the delta for this section. */
- info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
+ 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 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], loop->from[n]);
- tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
- tmp, info->stride[n]);
- tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
- build_int_cst (gfc_array_index_type, -1));
+ 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;
loop->temp_ss->string_length);
tmp = loop->temp_ss->data.temp.type;
- len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
+
+ gcc_assert (loop->temp_ss->data.info.dimen != 0);
+ for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
+ loop->temp_ss->data.info.dim[n] = n;
+
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
&loop->temp_ss->data.info, tmp, NULL_TREE,
false, true, false, where);
for (n = 0; n < info->dimen; n++)
{
- dim = info->dim[n];
-
/* If we are specifying the range the delta is already set. */
if (loopspec[n] != ss)
{
+ dim = ss->data.info.dim[n];
+
/* Calculate the offset relative to the loop variable.
- First multiply by the stride. */
+ First multiply by the stride. */
tmp = loop->from[n];
- if (!integer_onep (info->stride[n]))
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- tmp, info->stride[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 (MINUS_EXPR, gfc_array_index_type,
- info->start[n], tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ info->start[dim], tmp);
- info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
+ info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
}
}
}
}
-/* 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. 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 = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
- stride = stride * size;
- }
- return (stride);
- } */
-/*GCC ARRAYS*/
+/* 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. */
-static tree
-gfc_array_init_size (tree descriptor, int rank, tree * poffset,
- gfc_expr ** lower, gfc_expr ** upper,
- stmtblock_t * pblock)
+tree
+gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
{
- tree type;
- tree tmp;
- tree size;
- tree offset;
- tree stride;
+ 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 type;
+ tree tmp;
+ tree size;
+ tree offset;
+ tree stride;
+ tree element_size;
+ tree or_expr;
+ tree thencase;
+ tree elsecase;
tree cond;
- tree or_expr;
- tree thencase;
- tree elsecase;
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
- or_expr = NULL_TREE;
+ 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] */
+ 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. */
else
{
gcc_assert (lower[n]);
- if (ubound)
- {
+ 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];
- }
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
- tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify (pblock, tmp, se.expr);
+ 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 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
- offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
-
- /* Start the calculation for the size of this dimension. */
- size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, se.expr);
+ 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);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify (pblock, tmp, se.expr);
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
+ conv_ubound = se.expr;
/* Store the stride. */
- tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
- gfc_add_modify (pblock, tmp, 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);
+ }
- /* Calculate the size of this dimension. */
- size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
+ for (n = rank; n < rank + corank; n++)
+ {
+ ubound = upper[n];
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2 (LE_EXPR, boolean_type_node, size,
- gfc_index_zero_node);
- if (n == 0)
- or_expr = cond;
+ /* 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
- or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
-
- size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
- gfc_index_zero_node, size);
+ {
+ 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);
- /* Multiply the stride by the number of elements in this dimension. */
- stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
- stride = gfc_evaluate_now (stride, pblock);
+ 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. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
- fold_convert (gfc_array_index_type, tmp));
+ /* Convert to size_t. */
+ element_size = fold_convert (size_type_node, tmp);
+
+ if (rank == 0)
+ return element_size;
+
+ 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)
{
if (integer_zerop (or_expr))
return size;
if (integer_onep (or_expr))
- return gfc_index_zero_node;
+ 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, gfc_index_zero_node);
+ gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
thencase = gfc_finish_block (&thenblock);
gfc_start_block (&elseblock);
/*GCC ARRAYS*/
bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+ tree errlen)
{
tree tmp;
tree pointer;
- tree offset;
+ 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_array;
+ 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);
+ 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;
}
return false;
if (!prev_ref)
- allocatable_array = expr->symtree->n.sym->attr.allocatable;
+ {
+ allocatable = expr->symtree->n.sym->attr.allocatable;
+ coarray = expr->symtree->n.sym->attr.codimension;
+ dimension = expr->symtree->n.sym->attr.dimension;
+ }
else
- allocatable_array = prev_ref->u.c.component->attr.allocatable;
+ {
+ 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:
- lower = NULL;
- upper = ref->u.ar.start;
+ 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:
upper = ref->u.ar.as->upper;
break;
- case AR_SECTION:
- lower = ref->u.ar.start;
- upper = ref->u.ar.end;
- break;
-
default:
gcc_unreachable ();
break;
}
- size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
- lower, upper, &se->pre);
+ 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);
+
+ 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. */
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- /* The allocate_array variants take the old pointer as first argument. */
- if (allocatable_array)
- tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
+ 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, expr);
else
- tmp = gfc_allocate_with_status (&se->pre, size, pstat);
- tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
+ 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);
- tmp = gfc_conv_descriptor_offset (se->expr);
- gfc_add_modify (&se->pre, tmp, offset);
+ /* 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.derived->attr.alloc_comp)
+ if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+ && expr->ts.u.derived->attr.alloc_comp)
{
- tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
ref->u.ar.as->rank);
gfc_add_expr_to_block (&se->pre, tmp);
}
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = fold_build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ 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);
{
gfc_constructor *c;
tree tmp;
- mpz_t maxval;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
case EXPR_ARRAY:
/* Create a vector of all the elements. */
- for (c = expr->value.constructor; c; c = c->next)
+ 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_error_now ("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);
+ 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->n.offset, 0) != 0)
- index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->offset, 0) != 0)
+ index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
- mpz_init (maxval);
- if (mpz_cmp_si (c->repeat, 0) != 0)
- {
- tree tmp1, tmp2;
-
- mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->n.offset, maxval);
- mpz_sub_ui (maxval, maxval, 1);
- tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- if (mpz_cmp_si (c->n.offset, 0) != 0)
- {
- mpz_add_ui (maxval, c->n.offset, 1);
- tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- }
- else
- tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
-
- range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
- }
- else
- range = NULL;
- mpz_clear (maxval);
+
+ 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);
- 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_STRUCTURE:
gfc_conv_structure (&se, c->expr, 1);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
default:
- gcc_unreachable ();
+ /* 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;
}
+/* 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. */
gfc_add_modify (pblock, ubound, se.expr);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
- offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
+ 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)
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
{
/* Calculate stride = size * (ubound + 1 - lbound). */
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ 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
/* Make sure that negative size arrays are translated
to being zero size. */
- tmp = fold_build2 (GE_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
- tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
- stride, gfc_index_zero_node);
+ 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;
/* Generate code to initialize/allocate an array variable. */
-tree
-gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
+void
+gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
+ gfc_wrapped_block * block)
{
- stmtblock_t block;
+ stmtblock_t init;
tree type;
- tree tmp;
+ 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 fnbody;
+ return;
type = TREE_TYPE (decl);
gcc_assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
- gfc_start_block (&block);
+ gfc_init_block (&init);
/* Evaluate character string length. */
if (sym->ts.type == BT_CHARACTER
- && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
- gfc_trans_vla_type_sizes (sym, &block);
+ 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 (DECL_EXPR, TREE_TYPE (decl), decl);
- gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
+ gfc_add_expr_to_block (&init, tmp);
}
if (onstack)
{
- gfc_add_expr_to_block (&block, fnbody);
- return gfc_finish_block (&block);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ return;
}
type = TREE_TYPE (type);
gcc_assert (!sym->module);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && !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, &block);
+ 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 (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
- gfc_add_expr_to_block (&block, fnbody);
- return gfc_finish_block (&block);
+ gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ return;
}
- /* 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 (MULT_EXPR, gfc_array_index_type, size,
- fold_convert (gfc_array_index_type, tmp));
+ 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 (&block, TREE_TYPE (decl), size);
- gfc_add_modify (&block, decl, 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 (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
-
+ gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Automatic arrays should not have initializers. */
gcc_assert (!sym->value);
- gfc_add_expr_to_block (&block, fnbody);
-
- /* Free the temporary. */
- tmp = gfc_call_free (convert (pvoid_type_node, decl));
- gfc_add_expr_to_block (&block, tmp);
+ inittree = gfc_finish_block (&init);
- return gfc_finish_block (&block);
+ 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. */
-tree
-gfc_trans_g77_array (gfc_symbol * sym, tree body)
+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 block;
+ tree stmt;
+ stmtblock_t init;
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
/* Descriptor type. */
type = TREE_TYPE (parm);
gcc_assert (GFC_ARRAY_TYPE_P (type));
- gfc_start_block (&block);
+ gfc_start_block (&init);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && 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, &block);
+ gfc_trans_array_bounds (type, sym, &offset, &init);
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ 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 (&block, parm, tmp);
+ gfc_add_modify (&init, parm, tmp);
}
- stmt = gfc_finish_block (&block);
+ stmt = gfc_finish_block (&init);
- gfc_set_backend_locus (&loc);
-
- gfc_start_block (&block);
+ 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 ());
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
}
- gfc_add_expr_to_block (&block, stmt);
- gfc_add_expr_to_block (&block, body);
-
- return gfc_finish_block (&block);
+ gfc_add_init_cleanup (block, stmt, NULL_TREE);
}
Code is also added to copy the data back at the end of the function.
*/
-tree
-gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
+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 block;
- stmtblock_t cleanup;
+ stmtblock_t init;
+ tree stmtInit, stmtCleanup;
tree lbound;
tree ubound;
tree dubound;
tree dlbound;
tree dumdesc;
tree tmp;
- tree stmt;
tree stride, stride2;
tree stmt_packed;
tree stmt_unpacked;
/* Do nothing for pointer and allocatable arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
- return body;
+ return;
if (sym->attr.dummy && gfc_is_nodesc_array (sym))
- return gfc_trans_g77_array (sym, body);
+ {
+ gfc_trans_g77_array (sym, block);
+ return;
+ }
- gfc_get_backend_locus (&loc);
+ 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 (dumdesc);
- gfc_start_block (&block);
+ dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+ gfc_start_block (&init);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && 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 && flag_bounds_check);
+ 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));
+ || 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. */
+ 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 (dumdesc, gfc_rank_cst[0]);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
- gfc_add_modify (&block, partial, tmp);
+ 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;
- }
+ 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 (dumdesc, gfc_rank_cst[0]);
- stride = gfc_evaluate_now (stride, &block);
+ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+ stride = gfc_evaluate_now (stride, &init);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
- tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node, stride);
+ 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 (&block, stride, tmp);
+ gfc_add_modify (&init, stride, tmp);
/* Allow the user to disable array repacking. */
stmt_unpacked = NULL_TREE;
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 (gfor_fndecl_in_pack, 1, tmp);
+ stmt_unpacked = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, tmp);
stride = gfc_index_one_node;
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
{
/* Don't repack unknown shape arrays when the first stride is 1. */
- tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
- partial, stmt_packed, stmt_unpacked);
+ 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 (&block, tmpdesc, fold_convert (type, tmp));
+ gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
offset = gfc_index_zero_node;
size = gfc_index_one_node;
if (checkparm || !sym->as->upper[n])
{
/* Get the bounds of the actual parameter. */
- dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
- dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
+ 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 (&block, &se.pre);
- gfc_add_modify (&block, lbound, se.expr);
- }
+ {
+ 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))
- {
+ 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 (&block, &se.pre);
- gfc_add_modify (&block, ubound, se.expr);
- }
+ 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;
-
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- dubound, dlbound);
- tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
- asprintf (&msg, "%s for dimension %d of array '%s'",
- gfc_msg_bounds, n+1, sym->name);
- gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
- gfc_free (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 (MINUS_EXPR, gfc_array_index_type,
- dubound, dlbound);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
- gfc_add_modify (&block, ubound, tmp);
+ 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 (MULT_EXPR, gfc_array_index_type, lbound, stride);
- offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
+ 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);
+ {
+ stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
- if (no_repack || partial != NULL_TREE)
- {
- stmt_unpacked =
- gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[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 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- ubound, tmp);
- size = fold_build2 (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 (COND_EXPR, gfc_array_index_type, partial,
- stmt_unpacked, stmt_packed);
- else
- tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
- gfc_add_modify (&block, stride, tmp);
- }
- }
+ /* 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 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- ubound, tmp);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
- gfc_add_modify (&block, stride, tmp);
+ 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 (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
- gfc_trans_vla_type_sizes (sym, &block);
+ gfc_trans_vla_type_sizes (sym, &init);
- stmt = gfc_finish_block (&block);
-
- gfc_start_block (&block);
+ stmtInit = gfc_finish_block (&init);
/* Only do the entry/initialization code if the arg is present. */
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
+ build_empty_stmt (input_location));
}
- gfc_add_expr_to_block (&block, stmt);
-
- /* Add the main function body. */
- gfc_add_expr_to_block (&block, body);
/* Cleanup code. */
- if (!no_repack)
+ 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 (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
gfc_add_expr_to_block (&cleanup, tmp);
}
tmp = gfc_call_free (tmpdesc);
gfc_add_expr_to_block (&cleanup, tmp);
- stmt = gfc_finish_block (&cleanup);
+ stmtCleanup = gfc_finish_block (&cleanup);
/* Only do the cleanup if the array was repacked. */
- tmp = build_fold_indirect_ref (dumdesc);
+ tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
- tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ 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);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
- }
- gfc_add_expr_to_block (&block, stmt);
+ {
+ 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. */
- return gfc_finish_block (&block);
+ gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
+
+ gfc_restore_backend_locus (&loc);
}
}
tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
tmp = gfc_build_array_ref (tmp, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
case REF_COMPONENT:
field = ref->u.c.component->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field),
+ tmp, field, NULL_TREE);
break;
case REF_SUBSTRING:
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 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
- itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+ 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 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
- itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, itmp);
- stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+ 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);
}
}
-/* gfc_conv_expr_descriptor needs the character length of elemental
- functions before the function is called so that the size of the
- temporary can be obtained. The only way to do this is to convert
- the expression, mapping onto the actual arguments. */
+/* 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_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+get_array_charlen (gfc_expr *expr, gfc_se *se)
{
gfc_interface_mapping mapping;
gfc_formal_arglist *formal;
gfc_actual_arglist *arg;
gfc_se tse;
- formal = expr->symtree->n.sym->formal;
- arg = expr->value.function.actual;
- gfc_init_interface_mapping (&mapping);
-
- /* 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 (expr->ts.u.cl->length
+ && gfc_is_constant_expr (expr->ts.u.cl->length))
{
- if (!arg->expr)
- continue;
- if (formal->sym)
- gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ if (!expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+ return;
}
- gfc_init_se (&tse, NULL);
+ 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");
- /* Build the expression for the character length and convert it. */
- gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+ if (expr->value.op.op2)
+ {
+ get_array_charlen (expr->value.op.op2, se);
- 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 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
- build_int_cst (gfc_charlen_type_node, 0));
- expr->ts.cl->backend_decl = tse.expr;
- gfc_free_interface_mapping (&mapping);
+ 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 = expr->symtree->n.sym->formal;
+ 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
+dim_ok (gfc_ss_info *info)
+{
+ int n;
+ for (n = 0; n < info->dimen; n++)
+ if (info->dim[n] != n)
+ return false;
+ return true;
+}
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
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. */
+ 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_loopinfo loop;
- gfc_ss *secss;
gfc_ss_info *info;
int need_tmp;
int n;
tree offset;
int full;
bool subref_array_target = false;
+ gfc_expr *arg;
+ gcc_assert (ss != NULL);
gcc_assert (ss != gfc_ss_terminator);
/* Special case things we know we can pass easily. */
/* If we have a linear array section, we can pass it directly.
Otherwise we need to copy it into a temporary. */
- /* Find the SS for the array section. */
- secss = ss;
- while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
- secss = secss->next;
-
- gcc_assert (secss != gfc_ss_terminator);
- info = &secss->data.info;
+ gcc_assert (ss->type == GFC_SS_SECTION);
+ gcc_assert (ss->expr == expr);
+ info = &ss->data.info;
/* Get the descriptor for the array. */
- gfc_conv_ss_descriptor (&se->pre, secss, 0);
+ 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)))
else if (se->direct_byref)
full = 0;
else
- full = gfc_full_array_ref_p (info->ref);
+ full = gfc_full_array_ref_p (info->ref, NULL);
- if (full)
+ if (full && dim_ok (info))
{
- if (se->direct_byref)
+ if (se->direct_byref && !se->byref_noassign)
{
/* Copy the descriptor for pointer assignments. */
gfc_add_modify (&se->pre, se->expr, desc);
{
/* We pass full arrays directly. This means that pointers and
allocatable arrays should also work. */
- se->expr = build_fold_addr_expr (desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
}
else
{
break;
case EXPR_FUNCTION:
+
+ /* We don't need to copy data in some cases. */
+ arg = gfc_get_noncopying_intrinsic_argument (expr);
+ if (arg)
+ {
+ /* This is a call to transpose... */
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+ /* ... which has already been handled by the scalarizer, so
+ that we just need to get its argument's descriptor. */
+ gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
+ return;
+ }
+
/* 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 ar handled as
arbitrary expressions, i.e. copy to a temporary. */
- secss = ss;
- /* Look for the SS for this function. */
- while (secss != gfc_ss_terminator
- && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
- secss = secss->next;
if (se->direct_byref)
{
- gcc_assert (secss != gfc_ss_terminator);
+ gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
/* For pointer assignments pass the descriptor directly. */
- se->ss = secss;
- se->expr = build_fold_addr_expr (se->expr);
+ 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);
return;
}
- if (secss == gfc_ss_terminator)
+ if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
{
- /* Elemental 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));
+ else
+ gcc_assert (ss->type == GFC_SS_INTRINSIC);
+
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
- get_elemental_fcn_charlen (expr, se);
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ get_array_charlen (expr, se);
info = NULL;
}
else
{
/* Transformational function. */
- info = &secss->data.info;
+ info = &ss->data.info;
need_tmp = 0;
}
break;
{
need_tmp = 0;
info = &ss->data.info;
- secss = ss;
}
else
{
need_tmp = 1;
- secss = NULL;
info = NULL;
}
break;
default:
/* Something complicated. Copy it into a temporary. */
need_tmp = 1;
- secss = NULL;
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. */
if (need_tmp)
{
- /* Tell the scalarizer to make a temporary. */
- loop.temp_ss = gfc_get_ss ();
- loop.temp_ss->type = GFC_SS_TEMP;
- loop.temp_ss->next = gfc_ss_terminator;
-
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
-
- loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+ get_array_charlen (expr, se);
- if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
+ /* 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->string_length;
- loop.temp_ss->data.temp.dimen = loop.dimen;
+ gcc_assert (loop.temp_ss->data.temp.dimen == loop.dimen);
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
{
gfc_conv_expr (&rse, expr);
if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
- rse.expr = build_fold_indirect_ref (rse.expr);
+ rse.expr = build_fold_indirect_ref_loc (input_location,
+ rse.expr);
}
else
gfc_conv_expr_val (&rse, expr);
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_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->data.info.descriptor;
-
- gcc_assert (is_gimple_lvalue (desc));
}
- else if (expr->expr_type == EXPR_FUNCTION)
+ else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
{
desc = info->descriptor;
se->string_length = ss->string_length;
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;
+ int dim, ndim, codim;
tree parm;
tree parmtype;
tree stride;
tree to;
tree base;
+ ndim = info->ref ? info->ref->u.ar.dimen : info->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;
- gcc_assert (secss && secss != gfc_ss_terminator);
- if (se->direct_byref)
+ if (se->direct_byref && !se->byref_noassign)
{
/* For pointer assignments we fill in the destination. */
parm = se->expr;
{
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
loop.from, loop.to, 0,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
offset = gfc_index_zero_node;
- dim = 0;
/* 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, secss, loop} refer to the original, which maybe
+ {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
else
base = NULL_TREE;
- ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
for (n = 0; n < ndim; n++)
{
stride = gfc_conv_array_stride (desc, n);
}
else
{
- /* Check we haven't somehow got out of sync. */
- gcc_assert (info->dim[dim] == n);
-
/* Evaluate and remember the start of the section. */
- start = info->start[dim];
+ start = info->start[n];
stride = gfc_evaluate_now (stride, &loop.pre);
}
tmp = gfc_conv_array_lbound (desc, n);
- tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
-
- tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
- offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
+ 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)
/* 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 (info->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];
|| info->ref->u.ar.type != AR_FULL)
&& !integer_onep (from))
{
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, from);
- to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
+ 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;
}
- tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
- gfc_add_modify (&loop.pre, tmp, from);
+ gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+ gfc_rank_cst[dim], from);
/* Set the new upper bound. */
- tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
- gfc_add_modify (&loop.pre, tmp, to);
+ 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 (MULT_EXPR, gfc_array_index_type,
- stride, info->stride[dim]);
+ 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)
+ if (se->direct_byref
+ && info->ref
+ && info->ref->u.ar.type != AR_FULL)
{
- base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
- base, stride);
+ 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 (MINUS_EXPR, TREE_TYPE (base),
- tmp, loop.from[dim]);
- tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
- tmp, gfc_conv_array_stride (desc, n));
- base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
- tmp, base);
+ 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. */
- tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
- gfc_add_modify (&loop.pre, tmp, stride);
+ gfc_conv_descriptor_stride_set (&loop.pre, parm,
+ gfc_rank_cst[dim], stride);
+ }
- dim++;
+ 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);
+ gfc_conv_descriptor_data_set (&loop.pre, parm,
+ gfc_index_zero_node);
else
- /* Point the data pointer at the first element in the section. */
+ /* Point the data pointer at the 1st element in the section. */
gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
subref_array_target, expr);
&& !se->data_not_needed)
{
/* Set the offset. */
- tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify (&loop.pre, tmp, base);
+ 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. */
- tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
}
desc = parm;
}
- if (!se->direct_byref)
+ if (!se->direct_byref || se->byref_noassign)
{
/* Get a pointer to the new descriptor. */
if (se->want_pointer)
- se->expr = build_fold_addr_expr (desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
else
se->expr = desc;
}
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, gfc_ss * ss, int g77,
- const gfc_symbol *fsym, const char *proc_name)
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, 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, this_array_result;
+ 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);
- full_array_var = (expr->expr_type == EXPR_VARIABLE
- && expr->ref->u.ar.type == AR_FULL);
sym = full_array_var ? expr->symtree->n.sym : NULL;
/* The symbol should have an array specification. */
- gcc_assert (!sym || sym->as);
+ 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.cl->backend_decl = tmp;
+ expr->ts.u.cl->backend_decl = tmp;
se->string_length = tmp;
}
tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
- se->string_length = sym->ts.cl->backend_decl;
- if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ se->string_length = sym->ts.u.cl->backend_decl;
+
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
+ if (!sym->attr.pointer
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && !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 = build_fold_addr_expr (tmp);
+ 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, ss);
- se->expr = gfc_conv_array_data (se->expr);
+ tmp = se->expr;
}
- else
- se->expr = gfc_conv_array_data (tmp);
+ 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_SHAPE)
+ ||
+ (ref && ref->u.ar.as
+ && ref->u.ar.as->type != AS_DEFERRED
+ && 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, ss);
+ 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, ss);
- se->expr = build_fold_addr_expr (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 (se->expr));
+ se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
+ se->expr));
return;
}
/* Every other type of array. */
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss);
+ 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.derived->attr.alloc_comp
+ 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 (se->expr);
- tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
- gfc_add_expr_to_block (&se->post, tmp);
+ 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)
- {
- desc = se->expr;
+ 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", &expr->where);
}
- ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
+ 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 (COND_EXPR, TREE_TYPE (se->expr), tmp,
- fold_convert (TREE_TYPE (se->expr), ptr),
+ 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);
- se->expr = ptr;
+ /* 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.flag_check_array_temporaries)
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
{
char * msg;
else
asprintf (&msg, "An array temporary was created");
- tmp = build_fold_indirect_ref (desc);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ desc);
tmp = gfc_conv_array_data (tmp);
- tmp = fold_build2 (NE_EXPR, boolean_type_node,
- fold_convert (TREE_TYPE (tmp), ptr), 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 (TRUTH_AND_EXPR, boolean_type_node,
- gfc_conv_expr_present (sym), tmp);
+ 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);
- gfc_free (msg);
+ free (msg);
}
gfc_start_block (&block);
/* Copy the data back. */
if (fsym == NULL || fsym->attr.intent != INTENT_IN)
{
- tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
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 (desc);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ desc);
tmp = gfc_conv_array_data (tmp);
- tmp = fold_build2 (NE_EXPR, boolean_type_node,
- fold_convert (TREE_TYPE (tmp), ptr), 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 (TRUTH_AND_EXPR, boolean_type_node,
- gfc_conv_expr_present (sym), tmp);
+ 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 ());
+ 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);
}
}
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = fold_build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ 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);
tree nelems;
tree tmp;
idx = gfc_rank_cst[rank - 1];
- nelems = gfc_conv_descriptor_ubound (decl, idx);
- tmp = gfc_conv_descriptor_lbound (decl, idx);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ 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 (decl, idx);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ 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. */
+/* Allocate dest to the same size as src, and copy src -> dest.
+ If no_malloc is set, only the copy is done. */
-tree
-gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
+static tree
+duplicate_allocatable (tree dest, tree src, tree type, int rank,
+ bool no_malloc)
{
tree tmp;
tree size;
tree null_data;
stmtblock_t block;
- /* If the source is null, set the destination to null. */
+ /* If the source is null, set the destination to null. Then,
+ allocate memory to the destination. */
gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- null_data = gfc_finish_block (&block);
- 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, 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), size);
+ }
- nelems = get_full_array_size (&block, src, rank);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
- fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type))));
-
- /* Allocate memory to the destination. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- 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 = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src), 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. */
- null_cond = gfc_conv_descriptor_data_get (src);
+ 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 (NE_EXPR, boolean_type_node,
- null_cond, null_pointer_node);
+ 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};
+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,
gfc_loopinfo loop;
stmtblock_t fnblock;
stmtblock_t loopbody;
+ tree decl_type;
tree tmp;
tree comp;
tree dcmp;
gfc_init_block (&fnblock);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref (decl);
+ 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 (TREE_TYPE (decl)) == ARRAY_TYPE
- || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ if (TREE_CODE (decl_type) == ARRAY_TYPE
+ || GFC_DESCRIPTOR_TYPE_P (decl_type))
{
tmp = gfc_conv_array_data (decl);
- var = build_fold_indirect_ref (tmp);
+ var = build_fold_indirect_ref_loc (input_location,
+ tmp);
/* Get the number of elements - 1 and set the counter. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ 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 (MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ 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 (NE_EXPR, boolean_type_node, null_cond,
- build_int_cst (TREE_TYPE (null_cond), 0));
+ 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 (TREE_TYPE (decl));
+ tmp = array_type_nelts (decl_type);
tmp = fold_convert (gfc_array_index_type, tmp);
}
if (purpose == COPY_ALLOC_COMP)
{
- tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
- gfc_add_expr_to_block (&fnblock, tmp);
-
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
+ 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);
tmp = gfc_finish_block (&fnblock);
if (null_cond != NULL_TREE)
- tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, null_cond, tmp,
+ build_empty_stmt (input_location));
return tmp;
}
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.derived->attr.alloc_comp;
+ 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:
- /* Do not deallocate the components of ultimate pointer
- components. */
if (cmp_has_alloc_comps && !c->attr.pointer)
{
- comp = fold_build3 (COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ /* Do not deallocate the components of ultimate pointer
+ components. */
+ 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.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (c->attr.allocatable)
+ if (c->attr.allocatable
+ && (c->attr.dimension || c->attr.codimension))
{
- comp = fold_build3 (COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, 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 (&fnblock, tmp);
+
+ 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 scalar 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);
+
+ tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+ CLASS_DATA (c)->ts);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ 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);
+ }
break;
case NULLIFY_ALLOC_COMP:
if (c->attr.pointer)
continue;
- else if (c->attr.allocatable)
+ else if (c->attr.allocatable
+ && (c->attr.dimension|| c->attr.codimension))
{
- comp = fold_build3 (COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ 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 scalar 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);
+ 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 (COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ 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.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
continue;
/* We need source and destination components. */
- comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
- dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
+ 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->attr.allocatable && !cmp_has_alloc_comps)
{
- tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
+ rank = c->as ? c->as->rank : 0;
+ tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
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.derived, comp, dcmp,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
/* Recursively traverse an object of derived type, generating code to
- copy its allocatable components. */
+ copy it and its allocatable components. */
tree
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
}
+/* 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);
+ }
+ else 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);
+ }
+ else if (expr->expr_type == EXPR_FUNCTION)
+ {
+ /* A conversion function, so use the argument. */
+ expr = expr->value.function.actual->expr;
+ if (expr->expr_type != EXPR_VARIABLE)
+ return gfc_index_one_node;
+ desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+ return get_std_lbound (expr, desc, dim, assumed_size);
+ }
+
+ 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;
+ 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 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->expr && lss->expr->expr_type == EXPR_VARIABLE)
+ break;
+ if (lss == gfc_ss_terminator)
+ return NULL_TREE;
+ expr1 = lss->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->expr == expr1)
+ break;
+
+ if (lss == gfc_ss_terminator)
+ return NULL_TREE;
+
+ /* 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->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 = lss->data.info.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->data.info.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);
+
+
+ /* 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 (lss->data.info.saved_offset
+ && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
+ gfc_add_modify (&fblock, lss->data.info.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->data.info.dim[n];
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, tmp,
+ loop->from[dim]);
+ if (lss->data.info.delta[dim]
+ && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
+ gfc_add_modify (&fblock, lss->data.info.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);
+ 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);
+ 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)));
+ 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 (lss->data.info.data
+ && TREE_CODE (lss->data.info.data) == VAR_DECL)
+ {
+ tmp = gfc_conv_descriptor_data_get (desc);
+ gfc_add_modify (&fblock, lss->data.info.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. */
-tree
-gfc_trans_deferred_array (gfc_symbol * sym, tree body)
+void
+gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
{
tree type;
tree tmp;
tree descriptor;
- stmtblock_t fnblock;
+ 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.derived->attr.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 frontend bug: Deferred array size without pointer, "
+ fatal_error ("Possible front-end bug: Deferred array size without pointer, "
"allocatable attribute or derived type without allocatable "
"components.");
- gfc_init_block (&fnblock);
+ 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.cl->backend_decl))
+ && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
- gfc_trans_vla_type_sizes (sym, &fnblock);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+ gfc_trans_vla_type_sizes (sym, &init);
}
- /* Dummy and use associated variables don't need anything special. */
- if (sym->attr.dummy || sym->attr.use_assoc)
+ /* Dummy, use associated and result variables don't need anything special. */
+ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
{
- gfc_add_expr_to_block (&fnblock, body);
-
- return gfc_finish_block (&fnblock);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ gfc_restore_backend_locus (&loc);
+ return;
}
- gfc_get_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
descriptor = sym->backend_decl;
/* Although static, derived types with default initializers and
{
/* SAVEd variables are not freed on exit. */
gfc_trans_static_array_pointer (sym);
- return body;
+
+ 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)
+ if (!sym->attr.save
+ && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
{
- rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
- if (sym->value)
+ if (sym->value == NULL
+ || !gfc_has_default_initializer (sym->ts.u.derived))
{
- tmp = gfc_init_default_dt (sym, NULL);
- gfc_add_expr_to_block (&fnblock, tmp);
+ 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 (sym->backend_decl);
+ 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 (&fnblock, descriptor, null_pointer_node);
-
- gfc_add_expr_to_block (&fnblock, body);
+ gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
- gfc_set_backend_locus (&loc);
+ 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. */
{
int rank;
rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
+ tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
+ gfc_add_expr_to_block (&cleanup, tmp);
}
- if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
+ if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
+ && !sym->attr.save && !sym->attr.result)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
- gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_add_expr_to_block (&cleanup, tmp);
}
- return gfc_finish_block (&fnblock);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init),
+ gfc_finish_block (&cleanup));
}
/************ Expression Walking Functions ******************/
gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ref *ref;
- gfc_array_ref *ar;
- gfc_ss *newss;
- gfc_ss *head;
- int n;
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)
{
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ref->u.ss.start;
- newss->next = ss;
- ss = newss;
-
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ref->u.ss.end;
- newss->next = ss;
- ss = newss;
+ 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. */
continue;
ar = &ref->u.ar;
+
switch (ar->type)
{
case AR_ELEMENT:
- for (n = 0; n < ar->dimen; n++)
- {
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ar->start[n];
- newss->next = ss;
- ss = newss;
- }
+ for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
+ ss = gfc_get_scalar_ss (ss, ar->start[n]);
break;
case AR_FULL:
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SECTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = ar->as->rank;
+ newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
newss->data.info.ref = ref;
/* Make sure array is the same as array(:,:), this way
ar->dimen = ar->as->rank;
for (n = 0; n < ar->dimen; n++)
{
- newss->data.info.dim[n] = n;
ar->dimen_type[n] = DIMEN_RANGE;
gcc_assert (ar->start[n] == NULL);
break;
case AR_SECTION:
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SECTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = 0;
+ newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
newss->data.info.ref = ref;
- head = newss;
-
- /* We add SS chains for all the subscripts in the section. */
+ /* We add SS chains for all the subscripts in the section. */
for (n = 0; n < ar->dimen; n++)
{
gfc_ss *indexss;
case DIMEN_ELEMENT:
/* Add SS for elemental (scalar) subscripts. */
gcc_assert (ar->start[n]);
- indexss = gfc_get_ss ();
- indexss->type = GFC_SS_SCALAR;
- indexss->expr = ar->start[n];
- indexss->next = gfc_ss_terminator;
+ indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
break;
case DIMEN_VECTOR:
/* Create a GFC_SS_VECTOR index in which we can store
the vector's descriptor. */
- indexss = gfc_get_ss ();
- indexss->type = GFC_SS_VECTOR;
- indexss->expr = ar->start[n];
- indexss->next = gfc_ss_terminator;
+ indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
+ 1, GFC_SS_VECTOR);
indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
newss->data.info.dim[newss->data.info.dimen] = n;
gcc_unreachable ();
}
}
- /* We should have at least one non-elemental dimension. */
- gcc_assert (newss->data.info.dimen > 0);
+ /* We should have at least one non-elemental dimension,
+ unless we are creating a descriptor for a (scalar) coarray. */
+ gcc_assert (newss->data.info.dimen > 0
+ || newss->data.info.ref->u.ar.as->corank > 0);
ss = newss;
break;
{
gfc_ss *head;
gfc_ss *head2;
- gfc_ss *newss;
head = gfc_walk_subexpr (ss, expr->value.op.op1);
if (expr->value.op.op2 == NULL)
/* One of the operands needs scalarization, the other is scalar.
Create a gfc_ss for the scalar expression. */
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
if (head == ss)
{
/* First operand is scalar. We build the chain in reverse order, so
head = head->next;
/* Check we haven't somehow broken the chain. */
gcc_assert (head);
- newss->next = ss;
- head->next = newss;
- newss->expr = expr->value.op.op1;
+ head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
}
else /* head2 == head */
{
gcc_assert (head2 == head);
/* Second operand is scalar. */
- newss->next = head2;
- head2 = newss;
- newss->expr = expr->value.op.op2;
+ head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
}
return head2;
if (newss == head)
{
/* Scalar argument. */
- newss = gfc_get_ss ();
+ gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
+ newss = gfc_get_scalar_ss (head, arg->expr);
newss->type = type;
- newss->expr = arg->expr;
- newss->next = head;
}
else
scalar = 0;
static gfc_ss *
gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
gfc_intrinsic_sym *isym;
gfc_symbol *sym;
+ gfc_component *comp = NULL;
isym = expr->value.function.isym;
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
- if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
- {
- newss = gfc_get_ss ();
- newss->type = GFC_SS_FUNCTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
- return newss;
- }
+ gfc_is_proc_ptr_comp (expr, &comp);
+ 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. */
static gfc_ss *
gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
- int n;
-
- newss = gfc_get_ss ();
- newss->type = GFC_SS_CONSTRUCTOR;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
- for (n = 0; n < expr->rank; n++)
- newss->data.info.dim[n] = n;
-
- return newss;
+ 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. */
-static gfc_ss *
+gfc_ss *
gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *head;