/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+ Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
gcc_assert (DATA_FIELD == 0);
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return gfc_build_addr_expr (NULL, t);
+ return build_fold_addr_expr (t);
}
tree
}
-/* Build an null array descriptor constructor. */
+/* Build a null array descriptor constructor. */
tree
gfc_build_null_descriptor (tree type)
switch (ss->type)
{
case GFC_SS_SECTION:
- case GFC_SS_VECTOR:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
if (ss->data.info.subscript[n])
}
+/* If the bounds of SE's loop have not yet been set, see if they can be
+ determined from array spec AS, which is the array spec of a called
+ function. MAPPING maps the callee's dummy arguments to the values
+ that the caller is passing. Add any initialization and finalization
+ code to SE. */
+
+void
+gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
+ gfc_se * se, gfc_array_spec * as)
+{
+ int n, dim;
+ gfc_se tmpse;
+ tree lower;
+ tree upper;
+ tree tmp;
+
+ if (as && as->type == AS_EXPLICIT)
+ for (dim = 0; dim < se->loop->dimen; dim++)
+ {
+ n = se->loop->order[dim];
+ if (se->loop->to[n] == NULL_TREE)
+ {
+ /* Evaluate the lower bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ lower = tmpse.expr;
+
+ /* ...and the upper bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ upper = tmpse.expr;
+
+ /* Set the upper bound of the loop to UPPER - LOWER. */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->loop->to[n] = tmp;
+ }
+ }
+}
+
+
/* Generate code to allocate an array temporary, or create a variable to
- hold the data. If size is NULL zero the descriptor so that so that the
- callee will allocate the array. Also generates code to free the array
- afterwards. */
+ hold the data. If size is NULL, zero the descriptor so that the
+ callee will allocate the array. If DEALLOC is true, also generate code to
+ free the array afterwards.
+
+ Initialization code is added to PRE and finalization code to POST.
+ DYNAMIC is true if the caller may want to extend the array later
+ using realloc. This prevents us from putting the array on the stack. */
static void
-gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
- tree size, tree nelem)
+gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
+ gfc_ss_info * info, tree size, tree nelem,
+ bool dynamic, bool dealloc)
{
tree tmp;
tree args;
desc = info->descriptor;
info->offset = gfc_index_zero_node;
- if (size == NULL_TREE)
+ if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
- gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
+ gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
onstack = FALSE;
}
else
{
/* Allocate the temporary. */
- onstack = gfc_can_put_var_on_stack (size);
+ onstack = !dynamic && 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,
- integer_one_node);
+ gfc_index_one_node);
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 = gfc_build_addr_expr (NULL, tmp);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ tmp = build_fold_addr_expr (tmp);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
tmp = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
- tmp = gfc_build_function_call (tmp, args);
- tmp = gfc_evaluate_now (tmp, &loop->pre);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ tmp = build_function_call_expr (tmp, args);
+ tmp = gfc_evaluate_now (tmp, pre);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
/* The offset is zero because we create temporaries with a zero
lower bound. */
tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
- if (!onstack)
+ if (dealloc && !onstack)
{
/* Free the temporary. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = fold_convert (pvoid_type_node, tmp);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
- gfc_add_expr_to_block (&loop->post, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ gfc_add_expr_to_block (post, tmp);
}
}
-/* Generate code to allocate and initialize the descriptor for a temporary
+/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
- functions returning arrays. Adjusts the loop variables to be zero-based,
- and calculates the loop bounds for callee allocated arrays.
- Also fills in the descriptor, data and offset fields of info if known.
- Returns the size of the array, or NULL for a callee allocated array. */
+ functions returning arrays. Adjusts the loop variables to be
+ zero-based, and calculates the loop bounds for callee allocated arrays.
+ Allocate the array unless it's callee allocated (we have a callee
+ allocated array if 'callee_alloc' is true, or if loop->to[n] is
+ NULL_TREE for any n). Also fills in the descriptor, data and offset
+ fields of info if known. Returns the size of the array, or NULL for a
+ callee allocated array.
+
+ PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+ */
tree
-gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
- tree eltype)
+gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
+ gfc_loopinfo * loop, gfc_ss_info * info,
+ tree eltype, bool dynamic, bool dealloc,
+ bool callee_alloc)
{
tree type;
tree desc;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, size);
+ gfc_add_modify_expr (pre, tmp, size);
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
+ gfc_add_modify_expr (pre, tmp, loop->to[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
- size = gfc_evaluate_now (size, &loop->pre);
+ size = gfc_evaluate_now (size, pre);
}
/* Get the size of the array. */
nelem = size;
- if (size)
+ if (size && !callee_alloc)
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ size = NULL_TREE;
- gfc_trans_allocate_array_storage (loop, info, size, nelem);
+ gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
+ dealloc);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
}
+/* 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_expr (&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->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_expr (&se->pre,
+ gfc_conv_descriptor_stride (dest, dest_index),
+ gfc_conv_descriptor_stride (src, src_index));
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_lbound (dest, dest_index),
+ gfc_conv_descriptor_lbound (src, src_index));
+
+ gfc_add_modify_expr (&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] = 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. */
+ dest_info->offset = gfc_conv_descriptor_offset (src);
+ gfc_add_modify_expr (&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. */
+
+static tree
+gfc_get_iteration_count (tree start, tree end, tree step)
+{
+ tree tmp;
+ 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));
+ return fold_convert (gfc_array_index_type, tmp);
+}
+
+
+/* Extend the data in array DESC by EXTRA elements. */
+
+static void
+gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
+{
+ tree args;
+ tree tmp;
+ tree size;
+ tree ubound;
+
+ if (integer_zerop (extra))
+ return;
+
+ ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+
+ /* Add EXTRA to the upper bound. */
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
+ gfc_add_modify_expr (pblock, ubound, tmp);
+
+ /* Get the value of the current data pointer. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+
+ /* Calculate the new array size. */
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
+ tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
+ args = gfc_chainon_list (args, tmp);
+
+ /* Pick the appropriate realloc function. */
+ if (gfc_index_integer_kind == 4)
+ tmp = gfor_fndecl_internal_realloc;
+ else if (gfc_index_integer_kind == 8)
+ tmp = gfor_fndecl_internal_realloc64;
+ else
+ gcc_unreachable ();
+
+ /* Set the new data pointer. */
+ tmp = build_function_call_expr (tmp, args);
+ gfc_conv_descriptor_data_set (pblock, desc, tmp);
+}
+
+
+/* Return true if the bounds of iterator I can only be determined
+ at run time. */
+
+static inline bool
+gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
+{
+ return (i->start->expr_type != EXPR_CONSTANT
+ || i->end->expr_type != EXPR_CONSTANT
+ || i->step->expr_type != EXPR_CONSTANT);
+}
+
+
+/* Split the size of constructor element EXPR into the sum of two terms,
+ one of which can be determined at compile time and one of which must
+ be calculated at run time. Set *SIZE to the former and return true
+ if the latter might be nonzero. */
+
+static bool
+gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
+{
+ if (expr->expr_type == EXPR_ARRAY)
+ return gfc_get_array_constructor_size (size, expr->value.constructor);
+ else if (expr->rank > 0)
+ {
+ /* Calculate everything at run time. */
+ mpz_set_ui (*size, 0);
+ return true;
+ }
+ else
+ {
+ /* A single element. */
+ mpz_set_ui (*size, 1);
+ return false;
+ }
+}
+
+
+/* Like gfc_get_array_constructor_element_size, but applied to the whole
+ of array constructor C. */
+
+static bool
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+{
+ gfc_iterator *i;
+ mpz_t val;
+ mpz_t len;
+ bool dynamic;
+
+ mpz_set_ui (*size, 0);
+ mpz_init (len);
+ mpz_init (val);
+
+ dynamic = false;
+ for (; c; c = c->next)
+ {
+ i = c->iterator;
+ if (i && gfc_iterator_has_dynamic_bounds (i))
+ dynamic = true;
+ else
+ {
+ dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
+ if (i)
+ {
+ /* Multiply the static part of the element size by the
+ number of iterations. */
+ mpz_sub (val, i->end->value.integer, i->start->value.integer);
+ mpz_fdiv_q (val, val, i->step->value.integer);
+ mpz_add_ui (val, val, 1);
+ if (mpz_sgn (val) > 0)
+ mpz_mul (len, len, val);
+ else
+ mpz_set_ui (len, 0);
+ }
+ mpz_add (*size, *size, len);
+ }
+ }
+ mpz_clear (len);
+ mpz_clear (val);
+ return dynamic;
+}
+
+
/* Make sure offset is a variable. */
static void
/* Assign an element of an array constructor. */
static void
-gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
+gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
gfc_conv_expr (se, expr);
/* Store the value. */
- tmp = gfc_build_indirect_ref (pointer);
+ tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
args = gfc_chainon_list (args, se->expr);
args = gfc_chainon_list (args, se->string_length);
tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = gfc_build_function_call (tmp, args);
+ tmp = build_function_call_expr (tmp, args);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
}
-/* Add the contents of an array to the constructor. */
+/* Add the contents of an array to the constructor. DYNAMIC is as for
+ gfc_trans_array_constructor_value. */
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
- tree pointer, gfc_expr * expr,
- tree * poffset, tree * offsetvar)
+ tree desc, gfc_expr * expr,
+ tree * poffset, tree * offsetvar,
+ bool dynamic)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
+ tree size;
+ int n;
/* We need this to be a variable so we can increment it. */
gfc_put_offset_into_var (pblock, poffset, offsetvar);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
+ /* Make sure the constructed array has room for the new data. */
+ if (dynamic)
+ {
+ /* Set SIZE to the total number of elements in the subarray. */
+ size = gfc_index_one_node;
+ for (n = 0; n < loop.dimen; n++)
+ {
+ tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
+ gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ }
+
+ /* Grow the constructed array by SIZE elements. */
+ gfc_grow_array (&loop.pre, desc, size);
+ }
+
/* Make the loop body. */
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
- if (expr->ts.type == BT_CHARACTER)
- gfc_todo_error ("character arrays in constructors");
-
- gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
+ gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
}
-/* Assign the values to the elements of an array constructor. */
+/* Assign the values to the elements of an array constructor. DYNAMIC
+ is true if descriptor DESC only contains enough data for the static
+ size calculated by gfc_get_array_constructor_size. When true, memory
+ for the dynamic parts must be allocated using realloc. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree pointer, gfc_constructor * c,
- tree * poffset, tree * offsetvar)
+ tree desc, gfc_constructor * c,
+ tree * poffset, tree * offsetvar,
+ bool dynamic)
{
tree tmp;
stmtblock_t body;
gfc_se se;
+ mpz_t size;
+ mpz_init (size);
for (; c; c = c->next)
{
/* If this is an iterator or an array, the offset must be a variable. */
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
- gfc_trans_array_constructor_value (&body, type, pointer,
+ gfc_trans_array_constructor_value (&body, type, desc,
c->expr->value.constructor,
- poffset, offsetvar);
+ poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
{
- gfc_trans_array_constructor_subarray (&body, type, pointer,
- c->expr, poffset, offsetvar);
+ gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
+ poffset, offsetvar, dynamic);
}
else
{
{
/* Scalar values. */
gfc_init_se (&se, NULL);
- gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
- c->expr);
+ 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);
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
- (TREE_TYPE (pointer)))))
+ && POINTER_TYPE_P (type))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
- se.expr);
+ se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
- tmp = gfc_build_indirect_ref (pointer);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = build_fold_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, *poffset);
- tmp = gfc_build_addr_expr (NULL, tmp);
- init = gfc_build_addr_expr (NULL, init);
+ tmp = build_fold_addr_expr (tmp);
+ init = build_fold_addr_expr (init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (NULL_TREE, n * size);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_chainon_list (tmp, init);
tmp = gfc_chainon_list (tmp, bound);
- tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
+ tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
tmp);
gfc_add_expr_to_block (&body, tmp);
tree loopvar;
tree exit_label;
tree loopbody;
+ tree tmp2;
loopbody = gfc_finish_block (&body);
gfc_add_block_to_block (pblock, &se.pre);
step = gfc_evaluate_now (se.expr, pblock);
+ /* If this array expands dynamically, and the number of iterations
+ is not constant, we won't have allocated space for the static
+ part of C->EXPR's size. Do that now. */
+ if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
+ {
+ /* Get the number of iterations. */
+ tmp = gfc_get_iteration_count (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);
+ }
+
/* Generate the loop body. */
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&body);
gfc_add_expr_to_block (pblock, tmp);
}
}
-}
-
-
-/* Get the size of an expression. Returns -1 if the size isn't constant.
- Implied do loops with non-constant bounds are tricky because we must only
- evaluate the bounds once. */
-
-static void
-gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
-{
- gfc_iterator *i;
- mpz_t val;
- mpz_t len;
-
- mpz_set_ui (*size, 0);
- mpz_init (len);
- mpz_init (val);
-
- for (; c; c = c->next)
- {
- if (c->expr->expr_type == EXPR_ARRAY)
- {
- /* A nested array constructor. */
- gfc_get_array_cons_size (&len, c->expr->value.constructor);
- if (mpz_sgn (len) < 0)
- {
- mpz_set (*size, len);
- mpz_clear (len);
- mpz_clear (val);
- return;
- }
- }
- else
- {
- if (c->expr->rank > 0)
- {
- mpz_set_si (*size, -1);
- mpz_clear (len);
- mpz_clear (val);
- return;
- }
- mpz_set_ui (len, 1);
- }
-
- if (c->iterator)
- {
- i = c->iterator;
-
- if (i->start->expr_type != EXPR_CONSTANT
- || i->end->expr_type != EXPR_CONSTANT
- || i->step->expr_type != EXPR_CONSTANT)
- {
- mpz_set_si (*size, -1);
- mpz_clear (len);
- mpz_clear (val);
- return;
- }
-
- mpz_add (val, i->end->value.integer, i->start->value.integer);
- mpz_tdiv_q (val, val, i->step->value.integer);
- mpz_add_ui (val, val, 1);
- mpz_mul (len, len, val);
- }
- mpz_add (*size, *size, len);
- }
- mpz_clear (len);
- mpz_clear (val);
+ mpz_clear (size);
}
/* Array references don't change the string length. */
break;
- case COMPONENT_REF:
+ case REF_COMPONENT:
/* Use the length of the component. */
ts = &ref->u.c.component->ts;
break;
/* Figure out the string length of a character array constructor.
Returns TRUE if all elements are character constants. */
-static bool
+bool
get_array_ctor_strlen (gfc_constructor * c, tree * len)
{
bool is_const;
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
+ gfc_constructor *c;
tree offset;
tree offsetvar;
tree desc;
- tree size;
tree type;
bool const_string;
+ bool dynamic;
ss->data.info.dimen = loop->dimen;
+ c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- const_string = get_array_ctor_strlen (ss->expr->value.constructor,
- &ss->string_length);
+ const_string = get_array_ctor_strlen (c, &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
type = gfc_typenode_for_spec (&ss->expr->ts);
}
- size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
+ /* See if the constructor determines the loop bounds. */
+ dynamic = false;
+ if (loop->to[0] == NULL_TREE)
+ {
+ mpz_t size;
+
+ /* We should have a 1-dimensional, zero-based loop. */
+ gcc_assert (loop->dimen == 1);
+ gcc_assert (integer_zerop (loop->from[0]));
+
+ /* Split the constructor size into a static part and a dynamic part.
+ Allocate the static size up-front and record whether the dynamic
+ size might be nonzero. */
+ mpz_init (size);
+ dynamic = gfc_get_array_constructor_size (&size, c);
+ mpz_sub_ui (size, size, 1);
+ loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+ mpz_clear (size);
+ }
+
+ gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
+ type, dynamic, true, false);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_USED (offsetvar) = 0;
- gfc_trans_array_constructor_value (&loop->pre, type,
- ss->data.info.data,
- ss->expr->value.constructor, &offset,
- &offsetvar);
+ gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
+ &offset, &offsetvar, dynamic);
+
+ /* If the array grows dynamically, the upper bound of the loop variable
+ is determined by the array's final upper bound. */
+ if (dynamic)
+ loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
}
+/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+ called after evaluating all of INFO's vector dimensions. Go through
+ each such vector dimension and see if we can now fill in any missing
+ loop bounds. */
+
+static void
+gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
+{
+ gfc_se se;
+ tree tmp;
+ tree desc;
+ tree zero;
+ int n;
+ int dim;
+
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = info->dim[n];
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
+ && loop->to[n] == NULL)
+ {
+ /* Loop variable N indexes vector dimension DIM, and we don't
+ yet know the upper bound of loop variable N. Set it to the
+ difference between the vector's upper and lower bounds. */
+ gcc_assert (loop->from[n] == gfc_index_zero_node);
+ gcc_assert (info->subscript[dim]
+ && info->subscript[dim]->type == GFC_SS_VECTOR);
+
+ 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 = gfc_evaluate_now (tmp, &loop->pre);
+ loop->to[n] = tmp;
+ }
+ }
+}
+
+
/* Add the pre and post chains for all the scalar expressions in a SS chain
to loop. This is called after the loop parameters have been calculated,
but before the actual scalarizing loops. */
break;
case GFC_SS_SECTION:
- case GFC_SS_VECTOR:
- /* Scalarized expression. Evaluate any scalar subscripts. */
+ /* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
- {
- /* Add the expressions for scalar subscripts. */
- if (ss->data.info.subscript[n])
- gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
- }
+ if (ss->data.info.subscript[n])
+ gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
+
+ gfc_set_vector_loop_bounds (loop, &ss->data.info);
+ break;
+
+ case GFC_SS_VECTOR:
+ /* Get the vector's descriptor and store it in SS. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
+ gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_add_block_to_block (&loop->post, &se.post);
+ ss->data.info.descriptor = se.expr;
break;
case GFC_SS_INTRINSIC:
gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
+ ss->string_length = se.string_length;
break;
case GFC_SS_CONSTRUCTOR:
else
{
/* Descriptorless arrays. */
- return gfc_build_addr_expr (NULL, descriptor);
+ return build_fold_addr_expr (descriptor);
}
}
else
}
-/* Translate an array reference. The descriptor should be in se->expr.
- Do not use this function, it wil be removed soon. */
-/*GCC ARRAYS*/
-
-static void
-gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
- tree offset, int dimen)
-{
- tree array;
- tree tmp;
- tree index;
- int n;
-
- array = gfc_build_indirect_ref (pointer);
-
- index = offset;
- for (n = 0; n < dimen; n++)
- {
- /* index = index + stride[n]*indices[n] */
- tmp = gfc_conv_array_stride (se->expr, n);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
-
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
- }
-
- /* Result = data[index]. */
- tmp = gfc_build_array_ref (array, index);
-
- /* Check we've used the correct number of dimensions. */
- gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
-
- se->expr = tmp;
-}
-
-
/* Generate code to perform an array index bound check. */
static tree
}
-/* A reference to an array vector subscript. Uses recursion to handle nested
- vector subscripts. */
-
-static tree
-gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
-{
- tree descsave;
- tree indices[GFC_MAX_DIMENSIONS];
- gfc_array_ref *ar;
- gfc_ss_info *info;
- int n;
-
- gcc_assert (ss && ss->type == GFC_SS_VECTOR);
-
- /* Save the descriptor. */
- descsave = se->expr;
- info = &ss->data.info;
- se->expr = info->descriptor;
-
- ar = &info->ref->u.ar;
- for (n = 0; n < ar->dimen; n++)
- {
- switch (ar->dimen_type[n])
- {
- case DIMEN_ELEMENT:
- gcc_assert (info->subscript[n] != gfc_ss_terminator
- && info->subscript[n]->type == GFC_SS_SCALAR);
- indices[n] = info->subscript[n]->data.scalar.expr;
- break;
-
- case DIMEN_RANGE:
- indices[n] = index;
- break;
-
- case DIMEN_VECTOR:
- index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
-
- indices[n] =
- gfc_trans_array_bound_check (se, info->descriptor, index, n);
- break;
-
- default:
- gcc_unreachable ();
- }
- }
- /* Get the index from the vector. */
- gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
- index = se->expr;
- /* Put the descriptor back. */
- se->expr = descsave;
-
- return index;
-}
-
-
/* Return the offset for an index. Performs bound checking for elemental
dimensions. Single element references are processed separately. */
gfc_array_ref * ar, tree stride)
{
tree index;
+ tree desc;
+ tree data;
/* Get the index into the array for this dimension. */
if (ar)
{
gcc_assert (ar->type != AR_ELEMENT);
- if (ar->dimen_type[dim] == DIMEN_ELEMENT)
+ switch (ar->dimen_type[dim])
{
+ case DIMEN_ELEMENT:
gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
- && info->subscript[dim]->type == GFC_SS_SCALAR);
+ && info->subscript[dim]->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
index = info->subscript[dim]->data.scalar.expr;
index =
gfc_trans_array_bound_check (se, info->descriptor, index, dim);
- }
- else
- {
+ break;
+
+ case DIMEN_VECTOR:
+ gcc_assert (info && se->loop);
+ gcc_assert (info->subscript[dim]
+ && info->subscript[dim]->type == GFC_SS_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]);
+
+ /* Multiply the index by the stride. */
+ index = fold_build2 (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));
+ index = gfc_build_array_ref (data, index);
+ index = gfc_evaluate_now (index, &se->pre);
+
+ /* Do any bounds checking on the final info->descriptor index. */
+ index = gfc_trans_array_bound_check (se, info->descriptor,
+ index, dim);
+ break;
+
+ case DIMEN_RANGE:
/* Scalarized dimension. */
gcc_assert (info && se->loop);
info->stride[i]);
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]);
+ break;
- if (ar->dimen_type[dim] == DIMEN_VECTOR)
- {
- /* Handle vector subscripts. */
- index = gfc_conv_vector_array_index (se, index,
- info->subscript[dim]);
- index =
- gfc_trans_array_bound_check (se, info->descriptor, index,
- dim);
- }
- else
- gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
+ default:
+ gcc_unreachable ();
}
}
else
dimensions. */
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
- tmp = gfc_build_indirect_ref (info->data);
+ tmp = build_fold_indirect_ref (info->data);
se->expr = gfc_build_array_ref (tmp, index);
}
if (ar->type != AR_ELEMENT)
{
gfc_conv_scalarized_array_ref (se, ar);
+ gfc_advance_se_ss_chain (se);
return;
}
for (n = 0; n < ar->dimen; n++)
{
/* Calculate the index for this dimension. */
- gfc_init_se (&indexse, NULL);
+ 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);
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
- tmp = gfc_build_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref (tmp);
se->expr = gfc_build_array_ref (tmp, index);
}
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
int dim;
- gfc_ss *vecss;
gfc_expr *end;
tree desc;
tree bound;
gfc_se se;
+ gfc_ss_info *info;
gcc_assert (ss->type == GFC_SS_SECTION);
- /* For vector array subscripts we want the size of the vector. */
- dim = ss->data.info.dim[n];
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- {
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- dim = vecss->data.info.dim[0];
- }
+ info = &ss->data.info;
+ dim = info->dim[n];
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
- end = vecss->data.info.ref->u.ar.end[dim];
- desc = vecss->data.info.descriptor;
+ 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)
{
{
gfc_expr *start;
gfc_expr *stride;
- gfc_ss *vecss;
tree desc;
gfc_se se;
gfc_ss_info *info;
int dim;
- info = &ss->data.info;
+ gcc_assert (ss->type == GFC_SS_SECTION);
+ info = &ss->data.info;
dim = info->dim[n];
- /* For vector array subscripts we want the size of the vector. */
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
{
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- /* Get the descriptors for the vector subscripts as well. */
- if (!vecss->data.info.descriptor)
- gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
- dim = vecss->data.info.dim[0];
+ /* We use a zero-based index to access the vector. */
+ info->start[n] = gfc_index_zero_node;
+ info->stride[n] = gfc_index_one_node;
+ return;
}
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
- start = vecss->data.info.ref->u.ar.start[dim];
- stride = vecss->data.info.ref->u.ar.stride[dim];
- desc = vecss->data.info.descriptor;
+ gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+ desc = info->descriptor;
+ start = info->ref->u.ar.start[dim];
+ stride = info->ref->u.ar.stride[dim];
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
int n;
tree tmp;
gfc_ss *ss;
- gfc_ss *vecss;
tree desc;
loop->dimen = 0;
loop->dimen = ss->data.info.dimen;
break;
+ /* As usual, lbound and ubound are exceptions!. */
+ case GFC_SS_INTRINSIC:
+ switch (ss->expr->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ loop->dimen = ss->data.info.dimen;
+
+ default:
+ break;
+ }
+
default:
break;
}
gfc_conv_section_startstride (loop, ss, n);
break;
+ case GFC_SS_INTRINSIC:
+ switch (ss->expr->value.function.isym->generic_id)
+ {
+ /* Fall through to supply start and stride. */
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ break;
+ default:
+ continue;
+ }
+
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
for (n = 0; n < ss->data.info.dimen; n++)
gfc_start_block (&block);
- fault = integer_zero_node;
+ fault = boolean_false_node;
for (n = 0; n < loop->dimen; n++)
size[n] = NULL_TREE;
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
- /* This only checks scalarized dimensions, elemental dimensions are
- checked later. */
+ /* This code only checks ranges. Elemental and vector
+ dimensions are checked later. */
for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim]
- == DIMEN_VECTOR)
- {
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- dim = vecss->data.info.dim[0];
- }
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
- == DIMEN_RANGE);
- desc = vecss->data.info.descriptor;
+ if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+ continue;
+
+ desc = ss->data.info.descriptor;
/* Check lower bound. */
bound = gfc_conv_array_lbound (desc, dim);
if (ss->type != GFC_SS_SECTION)
continue;
- if (gfc_could_be_alias (dest, ss))
+ if (gfc_could_be_alias (dest, ss)
+ || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
{
nDepend = 1;
break;
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 =
- gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
+ 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;
tree tmp;
tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
+ bool dynamic[GFC_MAX_DIMENSIONS];
+ gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
for (n = 0; n < loop->dimen; n++)
{
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. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
gcc_assert (loop->dimen == 1);
- /* Try to figure out the size of the constructor. */
- /* TODO: avoid this by making the frontend set the shape. */
- gfc_get_array_cons_size (&i, ss->expr->value.constructor);
- /* A negative value means we failed. */
- if (mpz_sgn (i) > 0)
- {
- mpz_sub_ui (i, i, 1);
- loop->to[n] =
- gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
- loopspec[n] = ss;
- }
+
+ /* Always prefer to use the constructor bounds if the size
+ can be determined at compile time. Prefer not to otherwise,
+ since the general case involves realloc, and it's better to
+ avoid that overhead if possible. */
+ c = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, c);
+ if (!dynamic[n] || !loopspec[n])
+ loopspec[n] = ss;
continue;
}
specinfo = NULL;
info = &ss->data.info;
+ if (!specinfo)
+ loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
+ doesn't need realloc
stride of one
known stride
known lower bound
known upper bound
*/
- if (!specinfo)
+ else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
loopspec[n] = ss;
- /* TODO: Is != constructor correct? */
- else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
- {
- if (integer_onep (info->stride[n])
- && !integer_onep (specinfo->stride[n]))
- loopspec[n] = ss;
- else if (INTEGER_CST_P (info->stride[n])
- && !INTEGER_CST_P (specinfo->stride[n]))
- loopspec[n] = ss;
- else if (INTEGER_CST_P (info->start[n])
- && !INTEGER_CST_P (specinfo->start[n]))
- loopspec[n] = ss;
- /* We don't work out the upper bound.
- else if (INTEGER_CST_P (info->finish[n])
- && ! INTEGER_CST_P (specinfo->finish[n]))
- loopspec[n] = ss; */
- }
+ else if (integer_onep (info->stride[n])
+ && !integer_onep (specinfo->stride[n]))
+ loopspec[n] = ss;
+ else if (INTEGER_CST_P (info->stride[n])
+ && !INTEGER_CST_P (specinfo->stride[n]))
+ loopspec[n] = ss;
+ else if (INTEGER_CST_P (info->start[n])
+ && !INTEGER_CST_P (specinfo->start[n]))
+ loopspec[n] = ss;
+ /* We don't work out the upper bound.
+ else if (INTEGER_CST_P (info->finish[n])
+ && ! INTEGER_CST_P (specinfo->finish[n]))
+ loopspec[n] = ss; */
}
if (!loopspec[n])
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
- gcc_assert (info->dimen == 1);
- gcc_assert (loop->to[n]);
+ /* The upper bound is calculated when we expand the
+ constructor. */
+ gcc_assert (loop->to[n] == NULL_TREE);
break;
case GFC_SS_SECTION:
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;
- gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
+ gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
+ &loop->temp_ss->data.info, tmp, false, true,
+ false);
}
for (n = 0; n < loop->temp_dim; n++)
tree size;
tree offset;
tree stride;
+ tree cond;
+ tree or_expr;
+ tree thencase;
+ tree elsecase;
+ tree var;
+ stmtblock_t thenblock;
+ stmtblock_t elseblock;
gfc_expr *ubound;
gfc_se se;
int n;
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ or_expr = NULL_TREE;
+
for (n = 0; n < rank; n++)
{
/* We have 3 possibilities for determining the size of the array:
/* Calculate the size of this dimension. */
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
+ /* Check wether 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;
+ else
+ or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
+
/* 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);
*poffset = offset;
}
- size = gfc_evaluate_now (size, pblock);
- return size;
+ var = gfc_create_var (TREE_TYPE (size), "size");
+ gfc_start_block (&thenblock);
+ gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
+ thencase = gfc_finish_block (&thenblock);
+
+ gfc_start_block (&elseblock);
+ gfc_add_modify_expr (&elseblock, var, size);
+ elsecase = gfc_finish_block (&elseblock);
+
+ tmp = gfc_evaluate_now (or_expr, pblock);
+ tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+ gfc_add_expr_to_block (pblock, tmp);
+
+ return var;
}
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
-void
-gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
+bool
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
{
tree tmp;
tree pointer;
tree size;
gfc_expr **lower;
gfc_expr **upper;
+ gfc_ref *ref;
+ int allocatable_array;
+ int must_be_pointer;
+
+ ref = expr->ref;
+
+ /* In Fortran 95, components can only contain pointers, so that,
+ in ALLOCATE (foo%bar(2)), bar must be a pointer component.
+ We test this by checking for ref->next.
+ An implementation of TR 15581 would need to change this. */
+
+ if (ref)
+ must_be_pointer = ref->next != NULL;
+ else
+ must_be_pointer = 0;
+
+ /* Find the last reference in the chain. */
+ while (ref && ref->next != NULL)
+ {
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ ref = ref->next;
+ }
+
+ if (ref == NULL || ref->type != REF_ARRAY)
+ return false;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
tmp = gfc_conv_descriptor_data_addr (se->expr);
pointer = gfc_evaluate_now (tmp, &se->pre);
+ if (must_be_pointer)
+ allocatable_array = 0;
+ else
+ allocatable_array = expr->symtree->n.sym->attr.allocatable;
+
if (TYPE_PRECISION (gfc_array_index_type) == 32)
- allocate = gfor_fndecl_allocate;
+ {
+ if (allocatable_array)
+ allocate = gfor_fndecl_allocate_array;
+ else
+ allocate = gfor_fndecl_allocate;
+ }
else if (TYPE_PRECISION (gfc_array_index_type) == 64)
- allocate = gfor_fndecl_allocate64;
+ {
+ if (allocatable_array)
+ allocate = gfor_fndecl_allocate64_array;
+ else
+ allocate = gfor_fndecl_allocate64;
+ }
else
gcc_unreachable ();
tmp = gfc_chainon_list (NULL_TREE, pointer);
tmp = gfc_chainon_list (tmp, size);
tmp = gfc_chainon_list (tmp, pstat);
- tmp = gfc_build_function_call (allocate, tmp);
+ tmp = build_function_call_expr (allocate, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_add_modify_expr (&se->pre, tmp, offset);
+
+ return true;
}
/* Parameter is the address of the data component. */
tmp = gfc_chainon_list (NULL_TREE, var);
tmp = gfc_chainon_list (tmp, pstat);
- tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
if (dim + 1 < as->rank)
stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
else
- stride = NULL_TREE;
+ stride = GFC_TYPE_ARRAY_SIZE (type);
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
{
size = stride;
}
+ gfc_trans_vla_type_sizes (sym, pblock);
+
*poffset = offset;
return size;
}
{
gfc_trans_init_string_length (sym->ts.cl, &block);
+ gfc_trans_vla_type_sizes (sym, &block);
+
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
+ /* 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_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_expr_to_block (&block, fnbody);
+ return gfc_finish_block (&block);
+ }
+
/* 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));
fndecl = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
- tmp = gfc_build_function_call (fndecl, tmp);
+ tmp = build_function_call_expr (fndecl, tmp);
tmp = fold (convert (TREE_TYPE (decl), tmp));
gfc_add_modify_expr (&block, decl, tmp);
/* Free the temporary. */
tmp = convert (pvoid_type_node, decl);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
type = TREE_TYPE (tmpdesc);
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- dumdesc = gfc_build_indirect_ref (dumdesc);
+ dumdesc = build_fold_indirect_ref (dumdesc);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
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, integer_one_node);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
gfc_add_modify_expr (&block, partial, tmp);
}
else
stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
stride = gfc_evaluate_now (stride, &block);
- tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
+ tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
/* A library call to repack the array if necessary. */
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
+ stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
stride = gfc_index_one_node;
}
if (!INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->upper[n],
+ gfc_conv_expr_type (&se, sym->as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify_expr (&block, lbound, se.expr);
gfc_add_modify_expr (&block, 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_expr (&block, stride, tmp);
+ }
+ }
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_trans_vla_type_sizes (sym, &block);
+
stmt = gfc_finish_block (&block);
gfc_start_block (&block);
/* Copy the data back. */
tmp = gfc_chainon_list (NULL_TREE, dumdesc);
tmp = gfc_chainon_list (tmp, tmpdesc);
- tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
}
/* Free the temporary. */
tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
stmt = gfc_finish_block (&cleanup);
/* Only do the cleanup if the array was repacked. */
- tmp = gfc_build_indirect_ref (dumdesc);
+ tmp = build_fold_indirect_ref (dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
-/* Convert an array for passing as an actual parameter. Expressions and
+/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
a modified copy of the descriptor is passed, but using the original data.
- Also used for array pointer assignments by setting se->direct_byref. */
+
+ This function is also used for array pointer assignments, and there
+ are three cases:
+
+ - want_pointer && !se->direct_byref
+ EXPR is an actual argument. On exit, se->expr contains a
+ pointer to the array descriptor.
+
+ - !want_pointer && !se->direct_byref
+ EXPR is an actual argument to an intrinsic function or the
+ left-hand side of a pointer assignment. On exit, se->expr
+ contains the descriptor for EXPR.
+
+ - !want_pointer && se->direct_byref
+ EXPR is the right-hand side of a pointer assignment and
+ se->expr is the descriptor for the previously-evaluated
+ left-hand side. The function creates an assignment from
+ EXPR to se->expr. */
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
tree start;
tree offset;
int full;
- gfc_ss *vss;
gfc_ref *ref;
gcc_assert (ss != gfc_ss_terminator);
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
-
- need_tmp = 0;
- for (n = 0; n < secss->data.info.dimen; n++)
- {
- vss = secss->data.info.subscript[secss->data.info.dim[n]];
- if (vss && vss->type == GFC_SS_VECTOR)
- need_tmp = 1;
- }
-
info = &secss->data.info;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
- if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+
+ need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+ if (need_tmp)
+ full = 0;
+ else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
}
}
- /* Check for substring references. */
- ref = expr->ref;
- if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
- {
- while (ref->next)
- ref = ref->next;
- if (ref->type == REF_SUBSTRING)
- {
- /* In general character substrings need a copy. Character
- array strides are expressed as multiples of the element
- size (consistent with other array types), not in
- characters. */
- full = 0;
- need_tmp = 1;
- }
- }
-
if (full)
{
if (se->direct_byref)
{
/* We pass full arrays directly. This means that pointers and
allocatable arrays should also work. */
- se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+ se->expr = build_fold_addr_expr (desc);
}
else
{
/* For pointer assignments pass the descriptor directly. */
se->ss = secss;
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
gfc_conv_expr (se, expr);
return;
}
if (!need_tmp)
loop.array_parameter = 1;
else
- gcc_assert (se->want_pointer && !se->direct_byref);
+ /* The right-hand side of a pointer assignment mustn't use a temporary. */
+ gcc_assert (!se->direct_byref);
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
loop.temp_ss->next = gfc_ss_terminator;
if (expr->ts.type == BT_CHARACTER)
{
- gcc_assert (expr->ts.cl && expr->ts.cl->length
- && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
- loop.temp_ss->string_length = gfc_conv_mpz_to_tree
- (expr->ts.cl->length->value.integer,
- expr->ts.cl->length->ts.kind);
- expr->ts.cl->backend_decl = loop.temp_ss->string_length;
- }
- loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-
- /* ... which can hold our string, if present. */
- if (expr->ts.type == BT_CHARACTER)
- {
- loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+ if (expr->ts.cl
+ && expr->ts.cl->length
+ && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ expr->ts.cl->backend_decl
+ = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
+ expr->ts.cl->length->ts.kind);
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length
+ = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+ }
+ else
+ {
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ }
se->string_length = loop.temp_ss->string_length;
}
else
- loop.temp_ss->string_length = NULL;
+ {
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = NULL;
+ }
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_expr (&rse, expr);
- rse.expr = gfc_build_indirect_ref (rse.expr);
+ if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+ rse.expr = build_fold_indirect_ref (rse.expr);
}
else
gfc_conv_expr_val (&rse, expr);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
- /* Set the first stride component to zero to indicate a temporary. */
desc = loop.temp_ss->data.info.descriptor;
- tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
gcc_assert (is_gimple_lvalue (desc));
- se->expr = gfc_build_addr_expr (NULL, desc);
}
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
-
- if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL_TREE, desc);
- else
- se->expr = desc;
-
- if (expr->ts.type == BT_CHARACTER)
- se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+ se->string_length = ss->string_length;
}
else
{
/* Set the new lower bound. */
from = loop.from[dim];
to = loop.to[dim];
- if (!integer_onep (from))
+
+ /* If we have an array section or are assigning to a pointer,
+ make sure that the lower bound is 1. References to the full
+ array should otherwise keep the original bounds. */
+ if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
+ && !integer_onep (from))
{
- /* Make sure the new section starts at 1. */
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);
dim++;
}
- /* Point the data pointer at the first element in the section. */
- tmp = gfc_conv_array_data (desc);
- tmp = gfc_build_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, offset);
- offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
- gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
+ if (se->data_not_needed)
+ gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
+ else
+ {
+ /* Point the data pointer at the first element in the section. */
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_build_array_ref (tmp, offset);
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
+ }
- if (se->direct_byref)
+ if (se->direct_byref && !se->data_not_needed)
{
/* Set the offset. */
tmp = gfc_conv_descriptor_offset (parm);
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
}
+ desc = parm;
+ }
- if (!se->direct_byref)
- {
- /* Get a pointer to the new descriptor. */
- if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL, parm);
- else
- se->expr = parm;
- }
+ if (!se->direct_byref)
+ {
+ /* Get a pointer to the new descriptor. */
+ if (se->want_pointer)
+ se->expr = build_fold_addr_expr (desc);
+ else
+ se->expr = desc;
}
gfc_add_block_to_block (&se->pre, &loop.pre);
{
sym = expr->symtree->n.sym;
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
if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
se->expr = tmp;
else
- se->expr = gfc_build_addr_expr (NULL, tmp);
+ se->expr = build_fold_addr_expr (tmp);
return;
}
if (sym->attr.allocatable)
desc = se->expr;
/* Repack the array. */
tmp = gfc_chainon_list (NULL_TREE, desc);
- ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
+ ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
ptr = gfc_evaluate_now (ptr, &se->pre);
se->expr = ptr;
/* Copy the data back. */
tmp = gfc_chainon_list (NULL_TREE, desc);
tmp = gfc_chainon_list (tmp, ptr);
- tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&block, tmp);
/* Free the temporary. */
tmp = convert (pvoid_type_node, ptr);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
gfc_init_block (&block);
/* Only if it was repacked. This code needs to be executed before the
loop cleanup code. */
- tmp = gfc_build_indirect_ref (desc);
+ tmp = build_fold_indirect_ref (desc);
tmp = gfc_conv_array_data (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
-/* NULLIFY an allocated/pointer array on function entry, free it on exit. */
+/* Generate code to deallocate an array, if it is allocated. */
+
+tree
+gfc_trans_dealloc_allocated (tree descriptor)
+{
+ tree tmp;
+ tree deallocate;
+ stmtblock_t block;
+
+ gfc_start_block (&block);
+ deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
+
+ tmp = gfc_conv_descriptor_data_get (descriptor);
+ tmp = build2 (NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
+
+ tmp = gfc_finish_block (&block);
+
+ return tmp;
+}
+
+
+/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
tree
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
tree type;
tree tmp;
tree descriptor;
- tree deallocate;
- stmtblock_t block;
stmtblock_t fnblock;
locus loc;
gfc_init_block (&fnblock);
- gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
+ 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))
- gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ {
+ gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ gfc_trans_vla_type_sizes (sym, &fnblock);
+ }
- /* Parameter and use associated variables don't need anything special. */
+ /* Dummy and use associated variables don't need anything special. */
if (sym->attr.dummy || sym->attr.use_assoc)
{
gfc_add_expr_to_block (&fnblock, body);
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ 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);
+ type = TREE_TYPE (descriptor);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ }
/* NULLIFY the data pointer. */
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
/* Allocatable arrays need to be freed when they go out of scope. */
if (sym->attr.allocatable)
{
- gfc_start_block (&block);
-
- /* Deallocate if still allocated at the end of the procedure. */
- deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
-
- tmp = gfc_conv_descriptor_data_get (descriptor);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
-
- tmp = gfc_finish_block (&block);
+ tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
gfc_add_expr_to_block (&fnblock, tmp);
}
int n;
for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+ break;
+
+ for (; ref; ref = ref->next)
{
- /* We're only interested in array sections. */
+ 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;
+ }
+
+ /* We're only interested in array sections from now on. */
if (ref->type != REF_ARRAY)
continue;
switch (ar->type)
{
case AR_ELEMENT:
- /* TODO: Take elemental array references out of scalarization
- loop. */
+ 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;
+ }
break;
case AR_FULL:
gcc_assert (ar->end[n] == NULL);
gcc_assert (ar->stride[n] == NULL);
}
- return newss;
+ ss = newss;
+ break;
case AR_SECTION:
newss = gfc_get_ss ();
break;
case DIMEN_VECTOR:
- /* Get a SS for the vector. This will not be added to the
- chain directly. */
- indexss = gfc_walk_expr (ar->start[n]);
- if (indexss == gfc_ss_terminator)
- internal_error ("scalar vector subscript???");
-
- /* We currently only handle really simple vector
- subscripts. */
- if (indexss->next != gfc_ss_terminator)
- gfc_todo_error ("vector subscript expressions");
- indexss->loop_chain = gfc_ss_terminator;
-
- /* Mark this as a vector subscript. We don't add this
- directly into the chain, but as a subscript of the
- existing SS for this term. */
+ /* 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->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
- /* Also remember this dimension. */
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
}
/* We should have at least one non-elemental dimension. */
gcc_assert (newss->data.info.dimen > 0);
- return head;
+ ss = newss;
break;
default:
/* Reverse a SS chain. */
-static gfc_ss *
+gfc_ss *
gfc_reverse_ss (gfc_ss * ss)
{
gfc_ss *next;
/* Walk the arguments of an elemental function. */
gfc_ss *
-gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
+gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gfc_ss_type type)
{
- gfc_actual_arglist *arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
head = gfc_ss_terminator;
tail = NULL;
scalar = 1;
- for (arg = expr->value.function.actual; arg; arg = arg->next)
+ for (; arg; arg = arg->next)
{
if (!arg->expr)
continue;
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
if (sym->attr.elemental)
- return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
+ return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+ GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
res = gfc_walk_subexpr (gfc_ss_terminator, expr);
return gfc_reverse_ss (res);
}
-
OSDN Git Service
