/* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
ss->info->useflags = flags;
}
-static void gfc_free_ss (gfc_ss *);
-
/* Free a gfc_ss chain. */
/* Free a SS. */
-static void
+void
gfc_free_ss (gfc_ss * ss)
{
gfc_ss_info *ss_info;
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);
+ }
}
gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
{
gfc_ss *ss;
+ gfc_loopinfo *nested_loop;
if (head == gfc_ss_terminator)
return;
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
fields of info if known. Returns the size of the array, or NULL for a
callee allocated array.
+ 'eltype' == NULL signals that the temporary should be a class object.
+ The 'initial' expression is used to obtain the size of the dynamic
+ type; otehrwise the allocation and initialisation proceeds as for any
+ other expression
+
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 nelem;
tree cond;
tree or_expr;
+ tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
+ int total_dim = 0;
+
+ /* This signals a class array for which we need the size of the
+ dynamic type. Generate an eltype and then the class expression. */
+ if (eltype == NULL_TREE && initial)
+ {
+ if (POINTER_TYPE_P (TREE_TYPE (initial)))
+ class_expr = build_fold_indirect_ref_loc (input_location, initial);
+ eltype = TREE_TYPE (class_expr);
+ eltype = gfc_get_element_type (eltype);
+ /* Obtain the structure (class) expression. */
+ class_expr = TREE_OPERAND (class_expr, 0);
+ gcc_assert (class_expr);
+ }
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
info = &ss->info->data.array;
gcc_assert (ss->dimen > 0);
- gcc_assert (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;
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = gfc_evaluate_now (
+ total_dim += loop->dimen;
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = s->dim[n];
+
+ /* Callee allocated arrays may not have a known bound yet. */
+ if (loop->to[n])
+ loop->to[n] = gfc_evaluate_now (
fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
loop->to[n], loop->from[n]),
pre);
- loop->from[n] = gfc_index_zero_node;
-
- /* We have just changed the loop bounds, we must clear the
- corresponding specloop, so that delta calculation is not skipped
- later in 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_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;
}
if (size == NULL_TREE)
- {
- for (n = 0; n < loop->dimen; n++)
+ for (s = ss; s; s = s->parent)
+ for (n = 0; n < s->loop->dimen; n++)
{
- dim = ss->dim[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. */
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;
+ s->loop->to[n] = tmp;
}
- }
else
{
- for (n = 0; n < loop->dimen; n++)
+ 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);
/* Get the size of the array. */
if (size && !callee_alloc)
{
+ tree elemsize;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ elemsize = gfc_vtable_size_get (class_expr);
+
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size,
- fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type))));
+ size, elemsize);
}
else
{
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;
}
}
}
+
+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. */
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;
+ 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_typespec_chararray_ctor = typespec_chararray_ctor;
loop = ss->loop;
+ outer_loop = outermost_loop (loop);
ss_info = ss->info;
expr = ss_info->expr;
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_conv_expr_type (&length_se, expr->ts.u.cl->length,
gfc_charlen_type_node);
ss_info->string_length = length_se.expr;
- gfc_add_block_to_block (&loop->pre, &length_se.pre);
- gfc_add_block_to_block (&loop->post, &length_se.post);
+ 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,
+ const_string = get_array_ctor_strlen (&outer_loop->pre, c,
&ss_info->string_length);
/* Complex character array constructors should have been taken care of
/* 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_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))
static void
set_vector_loop_bounds (gfc_ss * ss)
{
- gfc_loopinfo *loop;
+ gfc_loopinfo *loop, *outer_loop;
gfc_array_info *info;
gfc_se se;
tree tmp;
int n;
int dim;
+ outer_loop = outermost_loop (ss->loop);
+
info = &ss->info->data.array;
- loop = ss->loop;
- for (n = 0; n < loop->dimen; n++)
+ 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. */
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;
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)
{
if (subscript)
se.expr = convert(gfc_array_index_type, se.expr);
if (!ss_info->where)
- se.expr = gfc_evaluate_now (se.expr, &loop->pre);
- gfc_add_block_to_block (&loop->pre, &se.post);
+ 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_info->data.scalar.value = se.expr;
ss_info->string_length = se.string_length;
break;
case GFC_SS_REFERENCE:
- /* Scalar argument to elemental procedure. Evaluate this
- now. */
+ /* Scalar argument to elemental procedure. */
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);
+ if (ss_info->data.scalar.can_be_null_ref)
+ {
+ /* If the actual argument can be absent (in other words, it can
+ be a NULL reference), don't try to evaluate it; pass instead
+ the reference directly. */
+ gfc_conv_expr_reference (&se, expr);
+ }
+ else
+ {
+ /* Otherwise, evaluate the argument outside the loop and pass
+ a reference to the value. */
+ gfc_conv_expr (&se, expr);
+ }
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
+ if (gfc_is_class_scalar_expr (expr))
+ /* This is necessary because the dynamic type will always be
+ large than the declared type. In consequence, assigning
+ the value to a temporary could segfault.
+ OOP-TODO: see if this is generally correct or is the value
+ has to be written to an allocated temporary, whose address
+ is passed via ss_info. */
+ ss_info->data.scalar.value = se.expr;
+ else
+ ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+ &outer_loop->pre);
- ss_info->data.scalar.value = gfc_evaluate_now (se.expr, &loop->pre);
ss_info->string_length = se.string_length;
break;
/* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (info->subscript[n])
- gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
+ {
+ 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;
/* 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);
+ 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;
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);
+ 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;
gfc_conv_expr_type (&se, expr->ts.u.cl->length,
gfc_charlen_type_node);
ss_info->string_length = se.expr;
- gfc_add_block_to_block (&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);
}
trans_array_constructor (ss, where);
break;
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);
}
}
+/* Build a scalarized array reference using the vptr 'size'. */
+
+static bool
+build_class_array_ref (gfc_se *se, tree base, tree index)
+{
+ tree type;
+ tree size;
+ tree offset;
+ tree decl;
+ tree tmp;
+ gfc_expr *expr = se->ss->info->expr;
+ gfc_ref *ref;
+ gfc_ref *class_ref;
+ gfc_typespec *ts;
+
+ if (expr == NULL || expr->ts.type != BT_CLASS)
+ return false;
+
+ if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+ ts = &expr->symtree->n.sym->ts;
+ else
+ ts = NULL;
+ class_ref = NULL;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS
+ && ref->next && ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
+ && ref->next->next
+ && ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.type != AR_ELEMENT)
+ {
+ ts = &ref->u.c.component->ts;
+ class_ref = ref;
+ break;
+ }
+ }
+
+ if (ts == NULL)
+ return false;
+
+ if (class_ref == NULL)
+ decl = expr->symtree->n.sym->backend_decl;
+ else
+ {
+ /* Remove everything after the last class reference, convert the
+ expression and then recover its tailend once more. */
+ gfc_se tmpse;
+ ref = class_ref->next;
+ class_ref->next = NULL;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, expr);
+ decl = tmpse.expr;
+ class_ref->next = ref;
+ }
+
+ size = gfc_vtable_size_get (decl);
+
+ /* Build the address of the element. */
+ type = TREE_TYPE (TREE_TYPE (base));
+ size = fold_convert (TREE_TYPE (index), size);
+ offset = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ index, size);
+ tmp = gfc_build_addr_expr (pvoid_type_node, base);
+ tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+ tmp = fold_convert (build_pointer_type (type), tmp);
+
+ /* Return the element in the se expression. */
+ se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+ return true;
+}
+
+
/* Build a scalarized reference to an array. */
static void
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
+
+ /* Use the vptr 'size' field to access a class the element of a class
+ array. */
+ if (build_class_array_ref (se, tmp, index))
+ return;
+
se->expr = gfc_build_array_ref (tmp, index, decl);
}
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;
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->info->useflags = 0;
+ if (ss->parent == NULL)
+ ss->info->useflags = 0;
}
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]);
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
&& 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);
}
/* Transform everything so we have a simple incrementing variable. */
- if (n < loop->dimen && integer_onep (info->stride[dim]))
+ if (integer_onep (info->stride[dim]))
info->delta[dim] = gfc_index_zero_node;
- else if (n < loop->dimen)
+ else
{
/* Set the delta for this section. */
info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
}
}
mpz_clear (i);
-}
-
-static void set_delta (gfc_loopinfo *loop);
+ for (loop = loop->nested; loop; loop = loop->next)
+ set_loop_bounds (loop);
+}
/* Initialize the scalarization loop. Creates the loop variables. Determines
tmp_ss_info = tmp_ss->info;
gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
+ gcc_assert (loop->parent == NULL);
/* Make absolutely sure that this is a complete type. */
if (tmp_ss_info->string_length)
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 array parameters we don't have loop variables, so don't calculate the
translations. */
- if (loop->array_parameter)
- return;
-
- set_delta (loop);
+ if (!loop->array_parameter)
+ gfc_set_delta (loop);
}
array: once loop bounds are chosen, sets the difference (DELTA field) between
loop bounds and array reference bounds, for each array info. */
-static void
-set_delta (gfc_loopinfo *loop)
+void
+gfc_set_delta (gfc_loopinfo *loop)
{
gfc_ss *ss, **loopspec;
gfc_array_info *info;
}
}
}
+
+ for (loop = loop->nested; loop; loop = loop->next)
+ gfc_set_delta (loop);
}
static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
- stmtblock_t * descriptor_block, tree * overflow)
+ stmtblock_t * descriptor_block, tree * overflow,
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
{
tree type;
tree tmp;
}
/* The stride is the number of elements in the array, so multiply by the
- size of an element to get the total size. */
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ size of an element to get the total size. Obviously, if there ia a
+ SOURCE expression (expr3) we must use its element size. */
+ if (expr3_elem_size != NULL_TREE)
+ tmp = expr3_elem_size;
+ else if (expr3 != NULL)
+ {
+ if (expr3->ts.type == BT_CLASS)
+ {
+ gfc_se se_sz;
+ gfc_expr *sz = gfc_copy_expr (expr3);
+ gfc_add_vptr_component (sz);
+ gfc_add_size_component (sz);
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ tmp = se_sz.expr;
+ }
+ else
+ {
+ tmp = gfc_typenode_for_spec (&expr3->ts);
+ tmp = TYPE_SIZE_UNIT (tmp);
+ }
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
/* Convert to size_t. */
element_size = fold_convert (size_type_node, tmp);
if (rank == 0)
return element_size;
+ *nelems = gfc_evaluate_now (stride, pblock);
stride = fold_convert (size_type_node, stride);
/* First check for overflow. Since an array of type character can
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
- tree errlen)
+ tree errlen, tree label_finish, tree expr3_elem_size,
+ tree *nelems, gfc_expr *expr3)
{
tree tmp;
tree pointer;
gfc_init_block (&set_descriptor_block);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
- &se->pre, &set_descriptor_block, &overflow);
+ &se->pre, &set_descriptor_block, &overflow,
+ expr3_elem_size, nelems, expr3);
if (dimension)
{
gfc_start_block (&elseblock);
/* Allocate memory to store the data. */
+ if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
/* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
gfc_allocate_allocatable (&elseblock, pointer, size, token,
- status, errmsg, errlen, expr);
+ status, errmsg, errlen, label_finish, expr);
else
gfc_allocate_using_malloc (&elseblock, pointer, size, status);
gfc_add_expr_to_block (&se->pre, tmp);
+ if (expr->ts.type == BT_CLASS)
+ {
+ tmp = build_int_cst (unsigned_char_type_node, 0);
+ /* With class objects, it is best to play safe and null the
+ memory because we cannot know if dynamic types have allocatable
+ components or not. */
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, pointer, tmp, size);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
- if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+ if ((expr->ts.type == BT_DERIVED)
&& expr->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
+gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
+ tree label_finish, gfc_expr* expr)
{
tree var;
tree tmp;
stmtblock_t block;
+ bool coarray = gfc_is_coarray (expr);
gfc_start_block (&block);
+
/* Get a pointer to the data. */
var = gfc_conv_descriptor_data_get (descriptor);
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = gfc_deallocate_with_status (var, pstat, false, expr);
+ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
+ errlen, label_finish, false, expr, coarray);
gfc_add_expr_to_block (&block, tmp);
- /* Zero the data pointer. */
+ /* Zero the data pointer; only for coarrays an error can occur and then
+ the allocation status may not be changed. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
var, build_int_cst (TREE_TYPE (var), 0));
+ if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree cond;
+ tree stat = build_fold_indirect_ref_loc (input_location, pstat);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ stat, build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, build_empty_stmt (input_location));
+ }
+
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
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 ((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);
/* Generate code to deallocate an array, if it is allocated. */
tree
-gfc_trans_dealloc_allocated (tree descriptor)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
{
tree tmp;
tree var;
/* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
+ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE, true,
+ NULL, coarray);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
gfc_loopinfo loop;
stmtblock_t fnblock;
stmtblock_t loopbody;
+ stmtblock_t tmpblock;
tree decl_type;
tree tmp;
tree comp;
tree ctype;
tree vref, dref;
tree null_cond = NULL_TREE;
+ bool called_dealloc_with_status;
gfc_init_block (&fnblock);
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
- if (cmp_has_alloc_comps && !c->attr.pointer)
- {
- /* Do not deallocate the components of ultimate pointer
- components. */
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
- rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose);
- gfc_add_expr_to_block (&fnblock, tmp);
- }
+
+ /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
+ (ie. this function) so generate all the calls and suppress the
+ recursion from here, if necessary. */
+ called_dealloc_with_status = false;
+ gfc_init_block (&tmpblock);
if (c->attr.allocatable
&& (c->attr.dimension || c->attr.codimension))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- tmp = gfc_trans_dealloc_allocated (comp);
- gfc_add_expr_to_block (&fnblock, tmp);
+ tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
+ gfc_add_expr_to_block (&tmpblock, tmp);
}
else if (c->attr.allocatable)
{
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
c->ts);
- gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ called_dealloc_with_status = true;
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
- gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_add_expr_to_block (&tmpblock, tmp);
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
- /* Allocatable scalar CLASS components. */
+ /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
- tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
- CLASS_DATA (c)->ts);
- gfc_add_expr_to_block (&fnblock, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+ tmp = gfc_trans_dealloc_allocated (comp,
+ CLASS_DATA (c)->attr.codimension);
+ else
+ {
+ tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+ CLASS_DATA (c)->ts);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ called_dealloc_with_status = true;
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ }
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ }
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
+ if (cmp_has_alloc_comps
+ && !c->attr.pointer
+ && !called_dealloc_with_status)
+ {
+ /* Do not deallocate the components of ultimate pointer
+ components or iteratively call self if call has been made
+ to gfc_trans_dealloc_allocated */
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ rank = c->as ? c->as->rank : 0;
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+ rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
+
+ /* Now add the deallocation of this component. */
+ gfc_add_block_to_block (&fnblock, &tmpblock);
break;
case NULLIFY_ALLOC_COMP:
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
- /* Allocatable scalar CLASS components. */
+ /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
- gfc_add_expr_to_block (&fnblock, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ else
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
else if (cmp_has_alloc_comps)
{
cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
+ if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+ {
+ tree ftn_tree;
+ tree size;
+ tree dst_data;
+ tree src_data;
+ tree null_data;
+
+ dst_data = gfc_class_data_get (dcmp);
+ src_data = gfc_class_data_get (comp);
+ size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+
+ if (CLASS_DATA (c)->attr.dimension)
+ {
+ nelems = gfc_conv_descriptor_size (src_data,
+ CLASS_DATA (c)->as->rank);
+ src_data = gfc_conv_descriptor_data_get (src_data);
+ dst_data = gfc_conv_descriptor_data_get (dst_data);
+ }
+ else
+ nelems = build_int_cst (size_type_node, 1);
+
+ gfc_init_block (&tmpblock);
+
+ /* We need to use CALLOC as _copy might try to free allocatable
+ components of the destination. */
+ ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
+ tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
+ size);
+ gfc_add_modify (&tmpblock, dst_data,
+ fold_convert (TREE_TYPE (dst_data), tmp));
+
+ tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_finish_block (&tmpblock);
+
+ gfc_init_block (&tmpblock);
+ gfc_add_modify (&tmpblock, dst_data,
+ fold_convert (TREE_TYPE (dst_data),
+ null_pointer_node));
+ null_data = gfc_finish_block (&tmpblock);
+
+ null_cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, src_data,
+ null_pointer_node);
+
+ gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
+ tmp, null_data));
+ continue;
+ }
+
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
gfc_array_index_type, cond,
lbound, gfc_index_one_node);
}
- else if (expr->expr_type == EXPR_VARIABLE)
+
+ if (expr->expr_type == EXPR_FUNCTION)
+ {
+ /* A conversion function, so use the argument. */
+ gcc_assert (expr->value.function.isym
+ && expr->value.function.isym->conversion);
+ expr = expr->value.function.actual->expr;
+ }
+
+ if (expr->expr_type == EXPR_VARIABLE)
{
tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
for (ref = expr->ref; ref; ref = ref->next)
}
return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
}
- else if (expr->expr_type == EXPR_FUNCTION)
- {
- /* A conversion function, so use the argument. */
- expr = expr->value.function.actual->expr;
- if (expr->expr_type != EXPR_VARIABLE)
- return gfc_index_one_node;
- desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
- return get_std_lbound (expr, desc, dim, assumed_size);
- }
return gfc_index_one_node;
}
if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
&& !sym->attr.save && !sym->attr.result)
{
- tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
+ tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
+ sym->attr.codimension);
gfc_add_expr_to_block (&cleanup, tmp);
}
}
-/* Walk the arguments of an elemental function. */
+/* Given an expression refering to a procedure, return the symbol of its
+ interface. We can't get the procedure symbol directly as we have to handle
+ the case of (deferred) type-bound procedures. */
+
+gfc_symbol *
+gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
+{
+ gfc_symbol *sym;
+ gfc_ref *ref;
+
+ if (procedure_ref == NULL)
+ return NULL;
+
+ /* Normal procedure case. */
+ sym = procedure_ref->symtree->n.sym;
+
+ /* Typebound procedure case. */
+ for (ref = procedure_ref->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer)
+ sym = ref->u.c.component->ts.interface;
+ else
+ sym = NULL;
+ }
+
+ return sym;
+}
+
+
+/* Walk the arguments of an elemental function.
+ PROC_EXPR is used to check whether an argument is permitted to be absent. If
+ it is NULL, we don't do the check and the argument is assumed to be present.
+*/
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
- gfc_ss_type type)
+ gfc_expr *proc_expr, gfc_ss_type type)
{
+ gfc_symbol *proc_ifc;
+ gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
head = gfc_ss_terminator;
tail = NULL;
+
+ proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
+ if (proc_ifc)
+ dummy_arg = proc_ifc->formal;
+ else
+ dummy_arg = NULL;
+
scalar = 1;
for (; arg; arg = arg->next)
{
- if (!arg->expr)
+ if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
continue;
newss = gfc_walk_subexpr (head, arg->expr);
gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
+
+ if (dummy_arg != NULL
+ && dummy_arg->sym->attr.optional
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && (gfc_expr_attr (arg->expr).optional
+ || gfc_expr_attr (arg->expr).allocatable
+ || gfc_expr_attr (arg->expr).pointer))
+ newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
+
+ if (dummy_arg != NULL)
+ dummy_arg = dummy_arg->next;
}
if (scalar)
sym = expr->value.function.esym;
if (!sym)
- sym = expr->symtree->n.sym;
+ sym = expr->symtree->n.sym;
/* A function that returns arrays. */
gfc_is_proc_ptr_comp (expr, &comp);
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
- if (sym->attr.elemental)
+ if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_REFERENCE);
+ expr, GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
OSDN Git Service
