gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
{
for (; ss != gfc_ss_terminator; ss = ss->next)
- ss->useflags = flags;
+ ss->info->useflags = flags;
}
-static void gfc_free_ss (gfc_ss *);
-
/* Free a gfc_ss chain. */
static void
free_ss_info (gfc_ss_info *ss_info)
{
+ ss_info->refcount--;
+ if (ss_info->refcount > 0)
+ return;
+
+ gcc_assert (ss_info->refcount == 0);
free (ss_info);
}
/* Free a SS. */
-static void
+void
gfc_free_ss (gfc_ss * ss)
{
gfc_ss_info *ss_info;
case GFC_SS_SECTION:
for (n = 0; n < ss->dimen; n++)
{
- if (ss->data.info.subscript[ss->dim[n]])
- gfc_free_ss_chain (ss->data.info.subscript[ss->dim[n]]);
+ if (ss_info->data.array.subscript[ss->dim[n]])
+ gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
}
break;
int i;
ss_info = gfc_get_ss_info ();
+ ss_info->refcount++;
ss_info->type = type;
ss_info->expr = expr;
int i;
ss_info = gfc_get_ss_info ();
+ ss_info->refcount++;
ss_info->type = GFC_SS_TEMP;
+ ss_info->string_length = string_length;
+ ss_info->data.temp.type = type;
ss = gfc_get_ss ();
ss->info = ss_info;
ss->next = gfc_ss_terminator;
- ss->string_length = string_length;
- ss->data.temp.type = type;
ss->dimen = dimen;
for (i = 0; i < ss->dimen; i++)
ss->dim[i] = i;
gfc_ss_info *ss_info;
ss_info = gfc_get_ss_info ();
+ ss_info->refcount++;
ss_info->type = GFC_SS_SCALAR;
ss_info->expr = expr;
void
gfc_cleanup_loop (gfc_loopinfo * loop)
{
+ gfc_loopinfo *loop_next, **ploop;
gfc_ss *ss;
gfc_ss *next;
gfc_free_ss (ss);
ss = next;
}
+
+ /* Remove reference to self in the parent loop. */
+ if (loop->parent)
+ for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
+ if (*ploop == loop)
+ {
+ *ploop = loop->next;
+ break;
+ }
+
+ /* Free non-freed nested loops. */
+ for (loop = loop->nested; loop; loop = loop_next)
+ {
+ loop_next = loop->next;
+ gfc_cleanup_loop (loop);
+ free (loop);
+ }
+}
+
+
+static void
+set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
+{
+ int n;
+
+ for (; ss != gfc_ss_terminator; ss = ss->next)
+ {
+ ss->loop = loop;
+
+ if (ss->info->type == GFC_SS_SCALAR
+ || ss->info->type == GFC_SS_REFERENCE
+ || ss->info->type == GFC_SS_TEMP)
+ continue;
+
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ if (ss->info->data.array.subscript[n] != NULL)
+ set_ss_loop (ss->info->data.array.subscript[n], loop);
+ }
}
gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
{
gfc_ss *ss;
+ gfc_loopinfo *nested_loop;
if (head == gfc_ss_terminator)
return;
+ set_ss_loop (head, loop);
+
ss = head;
for (; ss && ss != gfc_ss_terminator; ss = ss->next)
{
+ if (ss->nested_ss)
+ {
+ nested_loop = ss->nested_ss->loop;
+
+ /* More than one ss can belong to the same loop. Hence, we add the
+ loop to the chain only if it is different from the previously
+ added one, to avoid duplicate nested loops. */
+ if (nested_loop != loop->nested)
+ {
+ gcc_assert (nested_loop->parent == NULL);
+ nested_loop->parent = loop;
+
+ gcc_assert (nested_loop->next == NULL);
+ nested_loop->next = loop->nested;
+ loop->nested = nested_loop;
+ }
+ else
+ gcc_assert (nested_loop->parent == loop);
+ }
+
if (ss->next == gfc_ss_terminator)
ss->loop_chain = loop->ss;
else
gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
gfc_se * se, gfc_array_spec * as)
{
- int n, dim;
+ int n, dim, total_dim;
gfc_se tmpse;
+ gfc_ss *ss;
tree lower;
tree upper;
tree tmp;
- if (as && as->type == AS_EXPLICIT)
- for (n = 0; n < se->loop->dimen; n++)
- {
- dim = se->ss->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. */
- gfc_init_se (&tmpse, NULL);
- gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- gfc_add_block_to_block (&se->post, &tmpse.post);
- lower = fold_convert (gfc_array_index_type, tmpse.expr);
-
- /* ...and the upper bound. */
- gfc_init_se (&tmpse, NULL);
- gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- gfc_add_block_to_block (&se->post, &tmpse.post);
- upper = fold_convert (gfc_array_index_type, tmpse.expr);
-
- /* Set the upper bound of the loop to UPPER - LOWER. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, upper, lower);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->loop->to[n] = tmp;
- }
- }
+ total_dim = 0;
+
+ if (!as || as->type != AS_EXPLICIT)
+ return;
+
+ for (ss = se->ss; ss; ss = ss->parent)
+ {
+ total_dim += ss->loop->dimen;
+ for (n = 0; n < ss->loop->dimen; n++)
+ {
+ /* The bound is known, nothing to do. */
+ if (ss->loop->to[n] != NULL_TREE)
+ continue;
+
+ dim = ss->dim[n];
+ gcc_assert (dim < as->rank);
+ gcc_assert (ss->loop->dimen <= as->rank);
+
+ /* Evaluate the lower bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ lower = fold_convert (gfc_array_index_type, tmpse.expr);
+
+ /* ...and the upper bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ upper = fold_convert (gfc_array_index_type, tmpse.expr);
+
+ /* Set the upper bound of the loop to UPPER - LOWER. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, upper, lower);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ ss->loop->to[n] = tmp;
+ }
+ }
+
+ gcc_assert (total_dim == as->rank);
}
}
-/* 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.
- */
+/* Get the scalarizer array dimension corresponding to actual array dimension
+ given by ARRAY_DIM.
+
+ For example, if SS represents the array ref a(1,:,:,1), it is a
+ bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
+ and 1 for ARRAY_DIM=2.
+ If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
+ scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
+ ARRAY_DIM=3.
+ If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
+ array. If called on the inner ss, the result would be respectively 0,1,2 for
+ ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
+ for ARRAY_DIM=1,2. */
static int
-get_array_ref_dim (gfc_ss *ss, int loop_dim)
+get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
{
- int n, array_dim, array_ref_dim;
+ int array_ref_dim;
+ int n;
array_ref_dim = 0;
- array_dim = ss->dim[loop_dim];
- for (n = 0; n < ss->dimen; n++)
- if (ss->dim[n] < array_dim)
- array_ref_dim++;
+ for (; ss; ss = ss->parent)
+ for (n = 0; n < ss->dimen; n++)
+ if (ss->dim[n] < array_dim)
+ array_ref_dim++;
return array_ref_dim;
}
+static gfc_ss *
+innermost_ss (gfc_ss *ss)
+{
+ while (ss->nested_ss != NULL)
+ ss = ss->nested_ss;
+
+ return ss;
+}
+
+
+
+/* Get the array reference dimension corresponding to the given loop dimension.
+ It is different from the true array dimension given by the dim array in
+ the case of a partial array reference (i.e. a(:,:,1,:) for example)
+ It is different from the loop dimension in the case of a transposed array.
+ */
+
+static int
+get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
+{
+ return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
+ ss->dim[loop_dim]);
+}
+
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
callee allocated array.
PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
- gfc_trans_allocate_array_storage.
- */
+ gfc_trans_allocate_array_storage. */
tree
-gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
- gfc_loopinfo * loop, gfc_ss * ss,
+gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree eltype, tree initial, bool dynamic,
bool dealloc, bool callee_alloc, locus * where)
{
+ gfc_loopinfo *loop;
+ gfc_ss *s;
gfc_array_info *info;
tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
tree type;
tree cond;
tree or_expr;
int n, dim, tmp_dim;
+ int total_dim = 0;
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
- info = &ss->data.info;
+ info = &ss->info->data.array;
gcc_assert (ss->dimen > 0);
- gcc_assert (loop->dimen == ss->dimen);
+ gcc_assert (ss->loop->dimen == ss->dimen);
if (gfc_option.warn_array_temp && where)
gfc_warning ("Creating array temporary at %L", where);
/* Set the lower bound to zero. */
- for (n = 0; n < loop->dimen; n++)
+ for (s = ss; s; s = s->parent)
{
- dim = ss->dim[n];
+ loop = s->loop;
+
+ total_dim += loop->dimen;
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = s->dim[n];
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = gfc_evaluate_now (
+ /* 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 (ss, 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;
+ loop->from[n] = gfc_index_zero_node;
+
+ /* We have just changed the loop bounds, we must clear the
+ corresponding specloop, so that delta calculation is not skipped
+ later in gfc_set_delta. */
+ loop->specloop[n] = NULL;
+
+ /* We are constructing the temporary's descriptor based on the loop
+ dimensions. As the dimensions may be accessed in arbitrary order
+ (think of transpose) the size taken from the n'th loop may not map
+ to the n'th dimension of the array. We need to reconstruct loop
+ infos in the right order before using it to set the descriptor
+ bounds. */
+ tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
+ from[tmp_dim] = loop->from[n];
+ to[tmp_dim] = loop->to[n];
+
+ info->delta[dim] = gfc_index_zero_node;
+ info->start[dim] = gfc_index_zero_node;
+ info->end[dim] = gfc_index_zero_node;
+ info->stride[dim] = gfc_index_one_node;
+ }
}
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, ss->dimen, 0, from, to, 1,
+ gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
/* If there is at least one null loop->to[n], it is a callee allocated
array. */
- for (n = 0; n < loop->dimen; n++)
- if (loop->to[n] == NULL_TREE)
+ for (n = 0; n < total_dim; n++)
+ if (to[n] == NULL_TREE)
{
size = NULL_TREE;
break;
}
- for (n = 0; n < loop->dimen; n++)
- {
- dim = ss->dim[n];
-
- if (size == NULL_TREE)
+ if (size == NULL_TREE)
+ for (s = ss; s; s = s->parent)
+ for (n = 0; n < s->loop->dimen; n++)
{
+ dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
+
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
tmp = fold_build2_loc (input_location,
MINUS_EXPR, gfc_array_index_type,
gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
- loop->to[n] = tmp;
- continue;
+ s->loop->to[n] = tmp;
}
-
- /* Store the stride and bound components in the descriptor. */
- gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
+ else
+ {
+ for (n = 0; n < total_dim; n++)
+ {
+ /* Store the stride and bound components in the descriptor. */
+ gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
- gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
- gfc_index_zero_node);
+ gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+ gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
- to[n]);
+ gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- to[n], gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ to[n], gfc_index_one_node);
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
- gfc_index_zero_node);
- cond = gfc_evaluate_now (cond, pre);
+ /* Check whether the size for this dimension is negative. */
+ cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ tmp, gfc_index_zero_node);
+ cond = gfc_evaluate_now (cond, pre);
- if (n == 0)
- or_expr = cond;
- else
- or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, or_expr, cond);
+ if (n == 0)
+ or_expr = cond;
+ else
+ or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, or_expr, cond);
- size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, tmp);
- size = gfc_evaluate_now (size, pre);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ size = gfc_evaluate_now (size, pre);
+ }
}
/* Get the size of the array. */
-
if (size && !callee_alloc)
{
/* If or_expr is true, then the extent in at least one
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
dynamic, dealloc);
- if (ss->dimen > loop->temp_dim)
- loop->temp_dim = ss->dimen;
+ while (ss->parent)
+ ss = ss->parent;
+
+ if (ss->dimen > ss->loop->temp_dim)
+ ss->loop->temp_dim = ss->dimen;
return size;
}
tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
- info = &ss->data.info;
+ info = &ss->info->data.array;
info->descriptor = tmp;
info->data = gfc_build_addr_expr (NULL_TREE, tmp);
}
}
+
+static int
+get_rank (gfc_loopinfo *loop)
+{
+ int rank;
+
+ rank = 0;
+ for (; loop; loop = loop->parent)
+ rank += loop->dimen;
+
+ return rank;
+}
+
+
/* Helper routine of gfc_trans_array_constructor to determine if the
bounds of the loop specified by LOOP are constant and simple enough
to use with trans_constant_array_constructor. Returns the
iteration count of the loop if suitable, and NULL_TREE otherwise. */
static tree
-constant_array_constructor_loop_size (gfc_loopinfo * loop)
+constant_array_constructor_loop_size (gfc_loopinfo * l)
{
+ gfc_loopinfo *loop;
tree size = gfc_index_one_node;
tree tmp;
- int i;
+ int i, total_dim;
- for (i = 0; i < loop->dimen; i++)
+ total_dim = get_rank (l);
+
+ for (loop = l; loop; loop = loop->parent)
{
- /* If the bounds aren't constant, return NULL_TREE. */
- if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
- return NULL_TREE;
- if (!integer_zerop (loop->from[i]))
+ for (i = 0; i < loop->dimen; i++)
{
- /* Only allow nonzero "from" in one-dimensional arrays. */
- if (loop->dimen != 1)
+ /* If the bounds aren't constant, return NULL_TREE. */
+ if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
return NULL_TREE;
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[i], loop->from[i]);
+ if (!integer_zerop (loop->from[i]))
+ {
+ /* Only allow nonzero "from" in one-dimensional arrays. */
+ if (total_dim != 1)
+ return NULL_TREE;
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[i], loop->from[i]);
+ }
+ else
+ tmp = loop->to[i];
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, gfc_index_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
}
- else
- tmp = loop->to[i];
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, tmp);
}
return size;
}
+static tree *
+get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
+{
+ gfc_ss *ss;
+ int n;
+
+ gcc_assert (array->nested_ss == NULL);
+
+ for (ss = array; ss; ss = ss->parent)
+ for (n = 0; n < ss->loop->dimen; n++)
+ if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
+ return &(ss->loop->to[n]);
+
+ gcc_unreachable ();
+}
+
+
+static gfc_loopinfo *
+outermost_loop (gfc_loopinfo * loop)
+{
+ while (loop->parent != NULL)
+ loop = loop->parent;
+
+ return loop;
+}
+
+
/* Array constructors are handled by constructing a temporary, then using that
within the scalarization loop. This is not optimal, but seems by far the
simplest method. */
static void
-gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
+trans_array_constructor (gfc_ss * ss, locus * where)
{
gfc_constructor_base c;
tree offset;
tree desc;
tree type;
tree tmp;
+ tree *loop_ubound0;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
+ gfc_loopinfo *loop, *outer_loop;
+ gfc_ss_info *ss_info;
gfc_expr *expr;
+ gfc_ss *s;
/* Save the old values for nested checking. */
old_first_len = first_len;
old_first_len_val = first_len_val;
old_typespec_chararray_ctor = typespec_chararray_ctor;
- expr = ss->info->expr;
+ loop = ss->loop;
+ outer_loop = outermost_loop (loop);
+ ss_info = ss->info;
+ expr = ss_info->expr;
/* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
typespec was given for the array constructor. */
first_len = true;
}
- gcc_assert (ss->dimen == loop->dimen);
+ gcc_assert (ss->dimen == ss->loop->dimen);
c = expr->value.constructor;
if (expr->ts.type == BT_CHARACTER)
gfc_init_se (&length_se, NULL);
gfc_conv_expr_type (&length_se, 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);
- gfc_add_block_to_block (&loop->post, &length_se.post);
+ ss_info->string_length = length_se.expr;
+ gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &length_se.post);
}
else
- const_string = get_array_ctor_strlen (&loop->pre, c,
- &ss->string_length);
+ const_string = get_array_ctor_strlen (&outer_loop->pre, c,
+ &ss_info->string_length);
/* Complex character array constructors should have been taken care of
and not end up here. */
- gcc_assert (ss->string_length);
+ gcc_assert (ss_info->string_length);
- expr->ts.u.cl->backend_decl = ss->string_length;
+ expr->ts.u.cl->backend_decl = ss_info->string_length;
- type = gfc_get_character_type_len (expr->ts.kind, ss->string_length);
+ type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
if (const_string)
type = build_pointer_type (type);
}
/* See if the constructor determines the loop bounds. */
dynamic = false;
- if (expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
+ loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
+
+ if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
{
/* We have a multidimensional parameter. */
- int n;
- for (n = 0; n < expr->rank; n++)
- {
- loop->from[n] = gfc_index_zero_node;
- loop->to[n] = gfc_conv_mpz_to_tree (expr->shape [n],
- gfc_index_integer_kind);
- loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[n], gfc_index_one_node);
- }
+ for (s = ss; s; s = s->parent)
+ {
+ int n;
+ for (n = 0; n < s->loop->dimen; n++)
+ {
+ s->loop->from[n] = gfc_index_zero_node;
+ s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
+ gfc_index_integer_kind);
+ s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ s->loop->to[n],
+ gfc_index_one_node);
+ }
+ }
}
- if (loop->to[0] == NULL_TREE)
+ if (*loop_ubound0 == NULL_TREE)
{
mpz_t size;
/* We should have a 1-dimensional, zero-based loop. */
+ gcc_assert (loop->parent == NULL && loop->nested == NULL);
gcc_assert (loop->dimen == 1);
gcc_assert (integer_zerop (loop->from[0]));
}
}
- if (TREE_CODE (loop->to[0]) == VAR_DECL)
+ if (TREE_CODE (*loop_ubound0) == VAR_DECL)
dynamic = true;
- gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, ss,
- type, NULL_TREE, dynamic, true, false, where);
+ gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
+ NULL_TREE, dynamic, true, false, where);
- desc = ss->data.info.descriptor;
+ desc = ss_info->data.array.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_NO_WARNING (offsetvar) = 1;
TREE_USED (offsetvar) = 0;
- gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
+ gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
&offset, &offsetvar, dynamic);
/* If the array grows dynamically, the upper bound of the loop variable
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
offsetvar, gfc_index_one_node);
- tmp = gfc_evaluate_now (tmp, &loop->pre);
+ tmp = gfc_evaluate_now (tmp, &outer_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);
+ if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
+ gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
else
- loop->to[0] = tmp;
+ *loop_ubound0 = tmp;
}
if (TREE_USED (offsetvar))
loop bounds. */
static void
-set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss)
+set_vector_loop_bounds (gfc_ss * ss)
{
+ gfc_loopinfo *loop, *outer_loop;
gfc_array_info *info;
gfc_se se;
tree tmp;
int n;
int dim;
- info = &ss->data.info;
+ outer_loop = outermost_loop (ss->loop);
- for (n = 0; n < loop->dimen; n++)
+ info = &ss->info->data.array;
+
+ for (; ss; ss = ss->parent)
{
- dim = ss->dim[n];
- if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
- && loop->to[n] == NULL)
+ loop = ss->loop;
+
+ for (n = 0; n < loop->dimen; n++)
{
+ dim = ss->dim[n];
+ if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
+ || loop->to[n] != NULL)
+ continue;
+
/* Loop variable N indexes vector dimension DIM, and we don't
yet know the upper bound of loop variable N. Set it to the
difference between the vector's upper and lower bounds. */
&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
gfc_init_se (&se, NULL);
- desc = info->subscript[dim]->data.info.descriptor;
+ desc = info->subscript[dim]->info->data.array.descriptor;
zero = gfc_rank_cst[0];
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfc_conv_descriptor_ubound_get (desc, zero),
gfc_conv_descriptor_lbound_get (desc, zero));
- tmp = gfc_evaluate_now (tmp, &loop->pre);
+ tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
loop->to[n] = tmp;
}
}
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
locus * where)
{
+ gfc_loopinfo *nested_loop, *outer_loop;
gfc_se se;
gfc_ss_info *ss_info;
+ gfc_array_info *info;
gfc_expr *expr;
+ bool skip_nested = false;
int n;
+ outer_loop = outermost_loop (loop);
+
/* TODO: This can generate bad code if there are ordering dependencies,
e.g., a callee allocated function and an unknown size constructor. */
gcc_assert (ss != NULL);
{
gcc_assert (ss);
+ /* Cross loop arrays are handled from within the most nested loop. */
+ if (ss->nested_ss != NULL)
+ continue;
+
ss_info = ss->info;
expr = ss_info->expr;
+ info = &ss_info->data.array;
switch (ss_info->type)
{
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
if (expr->ts.type != BT_CHARACTER)
{
scalarization loop, except for WHERE assignments. */
if (subscript)
se.expr = convert(gfc_array_index_type, se.expr);
- if (!ss->where)
- se.expr = gfc_evaluate_now (se.expr, &loop->pre);
- gfc_add_block_to_block (&loop->pre, &se.post);
+ if (!ss_info->where)
+ se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
+ gfc_add_block_to_block (&outer_loop->pre, &se.post);
}
else
- gfc_add_block_to_block (&loop->post, &se.post);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
- ss->data.scalar.expr = se.expr;
- ss->string_length = se.string_length;
+ ss_info->data.scalar.value = se.expr;
+ ss_info->string_length = se.string_length;
break;
case GFC_SS_REFERENCE:
now. */
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- gfc_add_block_to_block (&loop->post, &se.post);
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
- ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
- ss->string_length = se.string_length;
+ ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+ &outer_loop->pre);
+ ss_info->string_length = se.string_length;
break;
case GFC_SS_SECTION:
/* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
- if (ss->data.info.subscript[n])
- gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
- where);
-
- set_vector_loop_bounds (loop, ss);
+ if (info->subscript[n])
+ {
+ gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
+ /* The recursive call will have taken care of the nested loops.
+ No need to do it twice. */
+ skip_nested = true;
+ }
+
+ set_vector_loop_bounds (ss);
break;
case GFC_SS_VECTOR:
/* Get the vector's descriptor and store it in SS. */
gfc_init_se (&se, NULL);
gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (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;
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
+ info->descriptor = se.expr;
break;
case GFC_SS_INTRINSIC:
se.loop = loop;
se.ss = ss;
gfc_conv_expr (&se, 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;
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
+ ss_info->string_length = se.string_length;
break;
case GFC_SS_CONSTRUCTOR:
if (expr->ts.type == BT_CHARACTER
- && ss->string_length == NULL
+ && ss_info->string_length == NULL
&& expr->ts.u.cl
&& expr->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, expr->ts.u.cl->length,
gfc_charlen_type_node);
- ss->string_length = se.expr;
- gfc_add_block_to_block (&loop->pre, &se.pre);
- gfc_add_block_to_block (&loop->post, &se.post);
+ ss_info->string_length = se.expr;
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
}
- gfc_trans_array_constructor (loop, ss, where);
+ trans_array_constructor (ss, where);
break;
case GFC_SS_TEMP:
gcc_unreachable ();
}
}
+
+ if (!skip_nested)
+ for (nested_loop = loop->nested; nested_loop;
+ nested_loop = nested_loop->next)
+ gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
}
{
gfc_se se;
gfc_ss_info *ss_info;
+ gfc_array_info *info;
tree tmp;
ss_info = ss->info;
+ info = &ss_info->data.array;
/* Get the descriptor for the array to be scalarized. */
gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
se.descriptor_only = 1;
gfc_conv_expr_lhs (&se, ss_info->expr);
gfc_add_block_to_block (block, &se.pre);
- ss->data.info.descriptor = se.expr;
- ss->string_length = se.string_length;
+ info->descriptor = se.expr;
+ ss_info->string_length = se.string_length;
if (base)
{
|| (TREE_CODE (tmp) == ADDR_EXPR
&& DECL_P (TREE_OPERAND (tmp, 0)))))
tmp = gfc_evaluate_now (tmp, block);
- ss->data.info.data = tmp;
+ info->data = tmp;
tmp = gfc_conv_array_offset (se.expr);
- ss->data.info.offset = gfc_evaluate_now (tmp, block);
+ 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;
+ info->saved_offset = info->offset;
}
}
if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
return index;
- descriptor = ss->data.info.descriptor;
+ descriptor = ss->info->data.array.descriptor;
index = gfc_evaluate_now (index, &se->pre);
tree desc;
tree data;
- info = &ss->data.info;
+ info = &ss->info->data.array;
/* Get the index into the array for this dimension. */
if (ar)
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->info->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
- index = info->subscript[dim]->data.scalar.expr;
+ index = info->subscript[dim]->info->data.scalar.value;
index = trans_array_bound_check (se, ss, index, dim, &ar->where,
ar->as->type != AS_ASSUMED_SIZE
gcc_assert (info && se->loop);
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
- desc = info->subscript[dim]->data.info.descriptor;
+ desc = info->subscript[dim]->info->data.array.descriptor;
/* Get a zero-based index into the vector. */
index = fold_build2_loc (input_location, MINUS_EXPR,
ss = se->ss;
expr = ss->info->expr;
- info = &ss->data.info;
+ info = &ss->info->data.array;
if (ar)
n = se->loop->order[0];
else
void
gfc_conv_tmp_array_ref (gfc_se * se)
{
- se->string_length = se->ss->string_length;
+ se->string_length = se->ss->info->string_length;
gfc_conv_scalarized_array_ref (se, NULL);
gfc_advance_se_ss_chain (se);
}
gfc_array_info *info;
tree stride, index;
- info = &ss->data.info;
+ info = &ss->info->data.array;
gfc_init_se (&se, NULL);
se.loop = loop;
stmtblock_t * pblock)
{
tree stride;
+ gfc_ss_info *ss_info;
gfc_array_info *info;
gfc_ss_type ss_type;
- gfc_ss *ss;
+ gfc_ss *ss, *pss;
+ gfc_loopinfo *ploop;
gfc_array_ref *ar;
int i;
for this dimension. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
- if ((ss->useflags & flag) == 0)
+ ss_info = ss->info;
+
+ if ((ss_info->useflags & flag) == 0)
continue;
- ss_type = ss->info->type;
+ ss_type = ss_info->type;
if (ss_type != GFC_SS_SECTION
&& ss_type != GFC_SS_FUNCTION
&& ss_type != GFC_SS_CONSTRUCTOR
&& ss_type != GFC_SS_COMPONENT)
continue;
- info = &ss->data.info;
+ info = &ss_info->data.array;
gcc_assert (dim < ss->dimen);
gcc_assert (ss->dimen == loop->dimen);
else
ar = NULL;
+ if (dim == loop->dimen - 1 && loop->parent != NULL)
+ {
+ /* If we are in the outermost dimension of this loop, the previous
+ dimension shall be in the parent loop. */
+ gcc_assert (ss->parent != NULL);
+
+ pss = ss->parent;
+ ploop = loop->parent;
+
+ /* ss and ss->parent are about the same array. */
+ gcc_assert (ss_info == pss->info);
+ }
+ else
+ {
+ ploop = loop;
+ pss = ss;
+ }
+
if (dim == loop->dimen - 1)
i = 0;
else
i = dim + 1;
/* For the time being, there is no loop reordering. */
- gcc_assert (i == loop->order[i]);
- i = loop->order[i];
+ gcc_assert (i == ploop->order[i]);
+ i = ploop->order[i];
- if (dim == loop->dimen - 1)
+ if (dim == loop->dimen - 1 && loop->parent == NULL)
{
- stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]);
+ stride = gfc_conv_array_stride (info->descriptor,
+ innermost_ss (ss)->dim[i]);
/* Calculate the stride of the innermost loop. Hopefully this will
allow the backend optimizers to do their stuff more effectively.
}
else
/* Add the offset for the previous loop dimension. */
- add_array_offset (pblock, loop, ss, ar, ss->dim[i], i);
+ add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
/* Remember this offset for the second loop. */
- if (dim == loop->temp_dim - 1)
+ if (dim == loop->temp_dim - 1 && loop->parent == NULL)
info->saved_offset = info->offset;
}
}
/* Clear all the used flags. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
- ss->useflags = 0;
+ if (ss->parent == NULL)
+ ss->info->useflags = 0;
}
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
gfc_ss_type ss_type;
+ gfc_ss_info *ss_info;
- if ((ss->useflags & 2) == 0)
+ ss_info = ss->info;
+
+ if ((ss_info->useflags & 2) == 0)
continue;
- ss_type = ss->info->type;
+ ss_type = ss_info->type;
if (ss_type != GFC_SS_SECTION
&& ss_type != GFC_SS_FUNCTION
&& ss_type != GFC_SS_CONSTRUCTOR
&& ss_type != GFC_SS_COMPONENT)
continue;
- ss->data.info.offset = ss->data.info.saved_offset;
+ ss_info->data.array.offset = ss_info->data.array.saved_offset;
}
/* Restart all the inner loops we just finished. */
gcc_assert (ss->info->type == GFC_SS_SECTION);
- info = &ss->data.info;
+ info = &ss->info->data.array;
ar = &info->ref->u.ar;
if (ar->dimen_type[dim] == DIMEN_VECTOR)
ss_info = ss->info;
expr = ss_info->expr;
- info = &ss->data.info;
+ info = &ss_info->data.array;
if (expr && expr->shape && !info->shape)
info->shape = expr->shape;
switch (ss_info->type)
{
case GFC_SS_SECTION:
- /* Get the descriptor for the array. */
- gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
+ /* Get the descriptor for the array. If it is a cross loops array,
+ we got the descriptor already in the outermost loop. */
+ if (ss->parent == NULL)
+ gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
for (n = 0; n < ss->dimen; n++)
gfc_conv_section_startstride (loop, ss, ss->dim[n]);
{
int dim = ss->dim[n];
- ss->data.info.start[dim] = gfc_index_zero_node;
- ss->data.info.end[dim] = gfc_index_zero_node;
- ss->data.info.stride[dim] = gfc_index_one_node;
+ info->start[dim] = gfc_index_zero_node;
+ info->end[dim] = gfc_index_zero_node;
+ info->stride[dim] = gfc_index_one_node;
}
break;
gfc_start_block (&inner);
/* TODO: range checking for mapped dimensions. */
- info = &ss->data.info;
+ info = &ss_info->data.array;
/* This code only checks ranges. Elemental and vector
dimensions are checked later. */
expr_loc, msg);
free (msg);
- desc = ss->data.info.descriptor;
+ desc = info->descriptor;
/* This is the run-time equivalent of resolve.c's
check_dimension(). The logical is more readable there
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&loop->pre, tmp);
}
+
+ for (loop = loop->nested; loop; loop = loop->next)
+ gfc_conv_ss_startstride (loop);
}
/* Return true if both symbols could refer to the same data object. Does
/* For derived types we must check all the component types. We can ignore
array references as these will have the same base type as the previous
component ref. */
- for (lref = lexpr->ref; lref != lss->data.info.ref; lref = lref->next)
+ for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
{
if (lref->type != REF_COMPONENT)
continue;
return 1;
}
- for (rref = rexpr->ref; rref != rss->data.info.ref;
+ for (rref = rexpr->ref; rref != rss->info->data.array.ref;
rref = rref->next)
{
if (rref->type != REF_COMPONENT)
lsym_pointer = lsym->attr.pointer;
lsym_target = lsym->attr.target;
- for (rref = rexpr->ref; rref != rss->data.info.ref; rref = rref->next)
+ for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
{
if (rref->type != REF_COMPONENT)
break;
if (GFC_ARRAY_TYPE_P (base_type)
|| GFC_DESCRIPTOR_TYPE_P (base_type))
base_type = gfc_get_element_type (base_type);
- loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
+ loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
loop->dimen);
gfc_add_ss_to_loop (loop, loop->temp_ss);
}
}
-/* Initialize the scalarization loop. Creates the loop variables. Determines
- the range of the loop variables. Creates a temporary if required.
- Calculates how to transform from loop variables to array indices for each
- expression. Also generates code for scalar expressions which have been
- moved outside the loop. */
+/* Browse through each array's information from the scalarizer and set the loop
+ bounds according to the "best" one (per dimension), i.e. the one which
+ provides the most information (constant bounds, shape, etc). */
-void
-gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
+static void
+set_loop_bounds (gfc_loopinfo *loop)
{
int n, dim, spec_dim;
gfc_array_info *info;
gfc_array_info *specinfo;
- gfc_ss *ss, *tmp_ss;
+ gfc_ss *ss;
tree tmp;
- gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
+ gfc_ss **loopspec;
bool dynamic[GFC_MAX_DIMENSIONS];
mpz_t *cshape;
mpz_t i;
+ loopspec = loop->specloop;
+
mpz_init (i);
for (n = 0; n < loop->dimen; n++)
{
|| ss_type == GFC_SS_REFERENCE)
continue;
- info = &ss->data.info;
+ info = &ss->info->data.array;
dim = ss->dim[n];
if (loopspec[n] != NULL)
{
- specinfo = &loopspec[n]->data.info;
+ specinfo = &loopspec[n]->info->data.array;
spec_dim = loopspec[n]->dim[n];
}
else
that's bad news. */
gcc_assert (loopspec[n]);
- info = &loopspec[n]->data.info;
+ info = &loopspec[n]->info->data.array;
dim = loopspec[n]->dim[n];
/* Set the extents of this range. */
&& INTEGER_CST_P (info->stride[dim]))
{
loop->from[n] = info->start[dim];
- mpz_set (i, cshape[get_array_ref_dim (loopspec[n], n)]);
+ mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
mpz_sub_ui (i, i, 1);
/* To = from + (size - 1) * stride. */
tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
loop->from[n] = gfc_index_zero_node;
}
}
+ mpz_clear (i);
+
+ for (loop = loop->nested; loop; loop = loop->next)
+ set_loop_bounds (loop);
+}
+
+
+/* Initialize the scalarization loop. Creates the loop variables. Determines
+ the range of the loop variables. Creates a temporary if required.
+ Also generates code for scalar expressions which have been
+ moved outside the loop. */
+
+void
+gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
+{
+ gfc_ss *tmp_ss;
+ tree tmp;
+
+ set_loop_bounds (loop);
/* Add all the scalar code that can be taken out of the loops.
This may include calculating the loop bounds, so do it before
tmp_ss_info = tmp_ss->info;
gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
+ gcc_assert (loop->parent == NULL);
/* Make absolutely sure that this is a complete type. */
- if (loop->temp_ss->string_length)
- loop->temp_ss->data.temp.type
+ if (tmp_ss_info->string_length)
+ tmp_ss_info->data.temp.type
= gfc_get_character_type_len_for_eltype
- (TREE_TYPE (loop->temp_ss->data.temp.type),
- loop->temp_ss->string_length);
+ (TREE_TYPE (tmp_ss_info->data.temp.type),
+ tmp_ss_info->string_length);
- tmp = loop->temp_ss->data.temp.type;
- memset (&loop->temp_ss->data.info, 0, sizeof (gfc_array_info));
+ tmp = tmp_ss_info->data.temp.type;
+ memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
tmp_ss_info->type = GFC_SS_SECTION;
gcc_assert (tmp_ss->dimen != 0);
- gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
- tmp_ss, tmp, NULL_TREE,
- false, true, false, where);
+ gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
+ NULL_TREE, false, true, false, where);
}
- for (n = 0; n < loop->temp_dim; n++)
- loopspec[loop->order[n]] = NULL;
-
- mpz_clear (i);
-
/* For array parameters we don't have loop variables, so don't calculate the
translations. */
- if (loop->array_parameter)
- return;
+ if (!loop->array_parameter)
+ gfc_set_delta (loop);
+}
+
+
+/* Calculates how to transform from loop variables to array indices for each
+ array: once loop bounds are chosen, sets the difference (DELTA field) between
+ loop bounds and array reference bounds, for each array info. */
+
+void
+gfc_set_delta (gfc_loopinfo *loop)
+{
+ gfc_ss *ss, **loopspec;
+ gfc_array_info *info;
+ tree tmp;
+ int n, dim;
+
+ loopspec = loop->specloop;
/* Calculate the translation from loop variables to array indices. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
&& ss_type != GFC_SS_CONSTRUCTOR)
continue;
- info = &ss->data.info;
+ info = &ss->info->data.array;
for (n = 0; n < ss->dimen; n++)
{
}
}
}
+
+ for (loop = loop->nested; loop; loop = loop->next)
+ gfc_set_delta (loop);
}
tree index, range;
VEC(constructor_elt,gc) *v = NULL;
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && expr->symtree->n.sym->value)
+ expr = expr->symtree->n.sym->value;
+
switch (expr->expr_type)
{
case EXPR_CONSTANT:
gcc_assert (ss_type == GFC_SS_SECTION);
gcc_assert (ss_expr == expr);
- info = &ss->data.info;
+ info = &ss_info->data.array;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, ss, 0);
gcc_assert ((expr->value.function.esym != NULL
&& expr->value.function.esym->attr.elemental)
|| (expr->value.function.isym != NULL
- && expr->value.function.isym->elemental));
+ && expr->value.function.isym->elemental)
+ || gfc_inline_intrinsic_function_p (expr));
else
gcc_assert (ss_type == GFC_SS_INTRINSIC);
else
{
/* Transformational function. */
- info = &ss->data.info;
+ info = &ss_info->data.array;
need_tmp = 0;
}
break;
&& gfc_constant_array_constructor_p (expr->value.constructor))
{
need_tmp = 0;
- info = &ss->data.info;
+ info = &ss_info->data.array;
}
else
{
: NULL),
loop.dimen);
- se->string_length = loop.temp_ss->string_length;
+ se->string_length = loop.temp_ss->info->string_length;
gcc_assert (loop.temp_ss->dimen == loop.dimen);
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
- desc = loop.temp_ss->data.info.descriptor;
+ desc = loop.temp_ss->info->data.array.descriptor;
}
else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
{
desc = info->descriptor;
- se->string_length = ss->string_length;
+ se->string_length = ss_info->string_length;
}
else
{
{
gcc_assert (info->subscript[n]
&& info->subscript[n]->info->type == GFC_SS_SCALAR);
- start = info->subscript[n]->data.scalar.expr;
+ start = info->subscript[n]->info->data.scalar.value;
}
else
{
stmtblock_t fblock;
gfc_ss *rss;
gfc_ss *lss;
+ gfc_array_info *linfo;
tree realloc_expr;
tree alloc_expr;
tree size1;
if (lss == gfc_ss_terminator)
return NULL_TREE;
+ linfo = &lss->info->data.array;
+
/* Find an ss for the rhs. For operator expressions, we see the
ss's for the operands. Any one of these will do. */
rss = loop->ss;
/* Since the lhs is allocatable, this must be a descriptor type.
Get the data and array size. */
- desc = lss->data.info.descriptor;
+ desc = linfo->descriptor;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
/* Get the rhs size. Fix both sizes. */
if (expr2)
- desc2 = rss->data.info.descriptor;
+ desc2 = rss->info->data.array.descriptor;
else
desc2 = NULL_TREE;
size2 = gfc_index_one_node;
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);
+ if (linfo->saved_offset
+ && TREE_CODE (linfo->saved_offset) == VAR_DECL)
+ gfc_add_modify (&fblock, linfo->saved_offset, tmp);
/* Now set the deltas for the lhs. */
for (n = 0; n < expr1->rank; n++)
tmp = 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);
+ if (linfo->delta[dim]
+ && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
+ gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
/* Get the new lhs size in bytes. */
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)
+ if (linfo->data
+ && TREE_CODE (linfo->data) == VAR_DECL)
{
tmp = gfc_conv_descriptor_data_get (desc);
- gfc_add_modify (&fblock, lss->data.info.data, tmp);
+ gfc_add_modify (&fblock, linfo->data, tmp);
}
/* Add the exit label. */
case AR_FULL:
newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
- newss->data.info.ref = ref;
+ newss->info->data.array.ref = ref;
/* Make sure array is the same as array(:,:), this way
we don't need to special case all the time. */
case AR_SECTION:
newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
- newss->data.info.ref = ref;
+ newss->info->data.array.ref = ref;
/* We add SS chains for all the subscripts in the section. */
for (n = 0; n < ar->dimen; n++)
gcc_assert (ar->start[n]);
indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
indexss->loop_chain = gfc_ss_terminator;
- newss->data.info.subscript[n] = indexss;
+ newss->info->data.array.subscript[n] = indexss;
break;
case DIMEN_RANGE:
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->info->data.array.subscript[n] = indexss;
newss->dim[newss->dimen] = n;
newss->dimen++;
break;
/* We should have at least one non-elemental dimension,
unless we are creating a descriptor for a (scalar) coarray. */
gcc_assert (newss->dimen > 0
- || newss->data.info.ref->u.ar.as->corank > 0);
+ || newss->info->data.array.ref->u.ar.as->corank > 0);
ss = newss;
break;