/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+ Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
gcc_assert (DATA_FIELD == 0);
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return gfc_build_addr_expr (NULL, t);
+ return build_fold_addr_expr (t);
}
tree
switch (ss->type)
{
case GFC_SS_SECTION:
- case GFC_SS_VECTOR:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
if (ss->data.info.subscript[n])
}
+/* If the bounds of SE's loop have not yet been set, see if they can be
+ determined from array spec AS, which is the array spec of a called
+ function. MAPPING maps the callee's dummy arguments to the values
+ that the caller is passing. Add any initialization and finalization
+ code to SE. */
+
+void
+gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
+ gfc_se * se, gfc_array_spec * as)
+{
+ int n, dim;
+ gfc_se tmpse;
+ tree lower;
+ tree upper;
+ tree tmp;
+
+ if (as && as->type == AS_EXPLICIT)
+ for (dim = 0; dim < se->loop->dimen; dim++)
+ {
+ n = se->loop->order[dim];
+ if (se->loop->to[n] == NULL_TREE)
+ {
+ /* Evaluate the lower bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ lower = tmpse.expr;
+
+ /* ...and the upper bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ upper = tmpse.expr;
+
+ /* Set the upper bound of the loop to UPPER - LOWER. */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->loop->to[n] = tmp;
+ }
+ }
+}
+
+
/* Generate code to allocate an array temporary, or create a variable to
- hold the data. If size is NULL zero the descriptor so that so that the
- callee will allocate the array. Also generates code to free the array
- afterwards.
+ hold the data. If size is NULL, zero the descriptor so that the
+ callee will allocate the array. If DEALLOC is true, also generate code to
+ free the array afterwards.
+ Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
-gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
- tree size, tree nelem, bool dynamic)
+gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
+ gfc_ss_info * info, tree size, tree nelem,
+ bool dynamic, bool dealloc)
{
tree tmp;
tree args;
if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
- gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
+ gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
onstack = FALSE;
}
else
{
/* Make a temporary variable to hold the data. */
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
- integer_one_node);
+ gfc_index_one_node);
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
tmp);
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
tmp);
tmp = gfc_create_var (tmp, "A");
- tmp = gfc_build_addr_expr (NULL, tmp);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ tmp = build_fold_addr_expr (tmp);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
tmp = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
- tmp = gfc_build_function_call (tmp, args);
- tmp = gfc_evaluate_now (tmp, &loop->pre);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ tmp = build_function_call_expr (tmp, args);
+ tmp = gfc_evaluate_now (tmp, pre);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
/* The offset is zero because we create temporaries with a zero
lower bound. */
tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
- if (!onstack)
+ if (dealloc && !onstack)
{
/* Free the temporary. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = fold_convert (pvoid_type_node, tmp);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
- gfc_add_expr_to_block (&loop->post, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ gfc_add_expr_to_block (post, tmp);
}
}
-/* Generate code to allocate and initialize the descriptor for a temporary
+/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
- functions returning arrays. Adjusts the loop variables to be zero-based,
- and calculates the loop bounds for callee allocated arrays.
- Also fills in the descriptor, data and offset fields of info if known.
- Returns the size of the array, or NULL for a callee allocated array.
+ functions returning arrays. Adjusts the loop variables to be
+ zero-based, and calculates the loop bounds for callee allocated arrays.
+ Allocate the array unless it's callee allocated (we have a callee
+ allocated array if 'callee_alloc' is true, or if loop->to[n] is
+ NULL_TREE for any n). Also fills in the descriptor, data and offset
+ fields of info if known. Returns the size of the array, or NULL for a
+ callee allocated array.
- DYNAMIC is as for gfc_trans_allocate_array_storage. */
+ PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+ */
tree
-gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
- tree eltype, bool dynamic)
+gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
+ gfc_loopinfo * loop, gfc_ss_info * info,
+ tree eltype, bool dynamic, bool dealloc,
+ bool callee_alloc)
{
tree type;
tree desc;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, size);
+ gfc_add_modify_expr (pre, tmp, size);
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
+ gfc_add_modify_expr (pre, tmp, loop->to[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
- size = gfc_evaluate_now (size, &loop->pre);
+ size = gfc_evaluate_now (size, pre);
}
/* Get the size of the array. */
nelem = size;
- if (size)
+ if (size && !callee_alloc)
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ size = NULL_TREE;
- gfc_trans_allocate_array_storage (loop, info, size, nelem, dynamic);
+ gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
+ dealloc);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
}
+/* Generate code to transpose array EXPR by creating a new descriptor
+ in which the dimension specifications have been reversed. */
+
+void
+gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
+{
+ tree dest, src, dest_index, src_index;
+ gfc_loopinfo *loop;
+ gfc_ss_info *dest_info, *src_info;
+ gfc_ss *dest_ss, *src_ss;
+ gfc_se src_se;
+ int n;
+
+ loop = se->loop;
+
+ src_ss = gfc_walk_expr (expr);
+ dest_ss = se->ss;
+
+ src_info = &src_ss->data.info;
+ dest_info = &dest_ss->data.info;
+ gcc_assert (dest_info->dimen == 2);
+ gcc_assert (src_info->dimen == 2);
+
+ /* Get a descriptor for EXPR. */
+ gfc_init_se (&src_se, NULL);
+ gfc_conv_expr_descriptor (&src_se, expr, src_ss);
+ gfc_add_block_to_block (&se->pre, &src_se.pre);
+ gfc_add_block_to_block (&se->post, &src_se.post);
+ src = src_se.expr;
+
+ /* Allocate a new descriptor for the return value. */
+ dest = gfc_create_var (TREE_TYPE (src), "atmp");
+ dest_info->descriptor = dest;
+ se->expr = dest;
+
+ /* Copy across the dtype field. */
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_dtype (dest),
+ gfc_conv_descriptor_dtype (src));
+
+ /* Copy the dimension information, renumbering dimension 1 to 0 and
+ 0 to 1. */
+ for (n = 0; n < 2; n++)
+ {
+ dest_info->delta[n] = gfc_index_zero_node;
+ dest_info->start[n] = gfc_index_zero_node;
+ dest_info->stride[n] = gfc_index_one_node;
+ dest_info->dim[n] = n;
+
+ dest_index = gfc_rank_cst[n];
+ src_index = gfc_rank_cst[1 - n];
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_stride (dest, dest_index),
+ gfc_conv_descriptor_stride (src, src_index));
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_lbound (dest, dest_index),
+ gfc_conv_descriptor_lbound (src, src_index));
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_ubound (dest, dest_index),
+ gfc_conv_descriptor_ubound (src, src_index));
+
+ if (!loop->to[n])
+ {
+ gcc_assert (integer_zerop (loop->from[n]));
+ loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (dest, dest_index),
+ gfc_conv_descriptor_lbound (dest, dest_index));
+ }
+ }
+
+ /* Copy the data pointer. */
+ dest_info->data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
+
+ /* Copy the offset. This is not changed by transposition: the top-left
+ element is still at the same offset as before. */
+ dest_info->offset = gfc_conv_descriptor_offset (src);
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_offset (dest),
+ dest_info->offset);
+
+ if (dest_info->dimen > loop->temp_dim)
+ loop->temp_dim = dest_info->dimen;
+}
+
+
/* Return the number of iterations in a loop that starts at START,
ends at END, and has step STEP. */
gcc_unreachable ();
/* Set the new data pointer. */
- tmp = gfc_build_function_call (tmp, args);
+ tmp = build_function_call_expr (tmp, args);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
gfc_conv_expr (se, expr);
/* Store the value. */
- tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
+ tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
args = gfc_chainon_list (args, se->expr);
args = gfc_chainon_list (args, se->string_length);
tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = gfc_build_function_call (tmp, args);
+ tmp = build_function_call_expr (tmp, args);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
- if (expr->ts.type == BT_CHARACTER)
- gfc_todo_error ("character arrays in constructors");
-
gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = gfc_build_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, *poffset);
- tmp = gfc_build_addr_expr (NULL, tmp);
- init = gfc_build_addr_expr (NULL, init);
+ tmp = build_fold_addr_expr (tmp);
+ init = build_fold_addr_expr (init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (NULL_TREE, n * size);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_chainon_list (tmp, init);
tmp = gfc_chainon_list (tmp, bound);
- tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
+ tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
tmp);
gfc_add_expr_to_block (&body, tmp);
/* Array references don't change the string length. */
break;
- case COMPONENT_REF:
+ case REF_COMPONENT:
/* Use the length of the component. */
ts = &ref->u.c.component->ts;
break;
/* Figure out the string length of a character array constructor.
Returns TRUE if all elements are character constants. */
-static bool
+bool
get_array_ctor_strlen (gfc_constructor * c, tree * len)
{
bool is_const;
mpz_clear (size);
}
- gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
+ gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
+ type, dynamic, true, false);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
}
+/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+ called after evaluating all of INFO's vector dimensions. Go through
+ each such vector dimension and see if we can now fill in any missing
+ loop bounds. */
+
+static void
+gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
+{
+ gfc_se se;
+ tree tmp;
+ tree desc;
+ tree zero;
+ int n;
+ int dim;
+
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = info->dim[n];
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
+ && loop->to[n] == NULL)
+ {
+ /* Loop variable N indexes vector dimension DIM, and we don't
+ yet know the upper bound of loop variable N. Set it to the
+ difference between the vector's upper and lower bounds. */
+ gcc_assert (loop->from[n] == gfc_index_zero_node);
+ gcc_assert (info->subscript[dim]
+ && info->subscript[dim]->type == GFC_SS_VECTOR);
+
+ gfc_init_se (&se, NULL);
+ desc = info->subscript[dim]->data.info.descriptor;
+ zero = gfc_rank_cst[0];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (desc, zero),
+ gfc_conv_descriptor_lbound (desc, zero));
+ tmp = gfc_evaluate_now (tmp, &loop->pre);
+ loop->to[n] = tmp;
+ }
+ }
+}
+
+
/* Add the pre and post chains for all the scalar expressions in a SS chain
to loop. This is called after the loop parameters have been calculated,
but before the actual scalarizing loops. */
break;
case GFC_SS_SECTION:
- case GFC_SS_VECTOR:
- /* Scalarized expression. Evaluate any scalar subscripts. */
+ /* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
- {
- /* Add the expressions for scalar subscripts. */
- if (ss->data.info.subscript[n])
- gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
- }
+ if (ss->data.info.subscript[n])
+ gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
+
+ gfc_set_vector_loop_bounds (loop, &ss->data.info);
+ break;
+
+ case GFC_SS_VECTOR:
+ /* Get the vector's descriptor and store it in SS. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
+ gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_add_block_to_block (&loop->post, &se.post);
+ ss->data.info.descriptor = se.expr;
break;
case GFC_SS_INTRINSIC:
else
{
/* Descriptorless arrays. */
- return gfc_build_addr_expr (NULL, descriptor);
+ return build_fold_addr_expr (descriptor);
}
}
else
}
-/* Translate an array reference. The descriptor should be in se->expr.
- Do not use this function, it wil be removed soon. */
-/*GCC ARRAYS*/
-
-static void
-gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
- tree offset, int dimen)
-{
- tree array;
- tree tmp;
- tree index;
- int n;
-
- array = gfc_build_indirect_ref (pointer);
-
- index = offset;
- for (n = 0; n < dimen; n++)
- {
- /* index = index + stride[n]*indices[n] */
- tmp = gfc_conv_array_stride (se->expr, n);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
-
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
- }
-
- /* Result = data[index]. */
- tmp = gfc_build_array_ref (array, index);
-
- /* Check we've used the correct number of dimensions. */
- gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
-
- se->expr = tmp;
-}
-
-
/* Generate code to perform an array index bound check. */
static tree
}
-/* A reference to an array vector subscript. Uses recursion to handle nested
- vector subscripts. */
-
-static tree
-gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
-{
- tree descsave;
- tree indices[GFC_MAX_DIMENSIONS];
- gfc_array_ref *ar;
- gfc_ss_info *info;
- int n;
-
- gcc_assert (ss && ss->type == GFC_SS_VECTOR);
-
- /* Save the descriptor. */
- descsave = se->expr;
- info = &ss->data.info;
- se->expr = info->descriptor;
-
- ar = &info->ref->u.ar;
- for (n = 0; n < ar->dimen; n++)
- {
- switch (ar->dimen_type[n])
- {
- case DIMEN_ELEMENT:
- gcc_assert (info->subscript[n] != gfc_ss_terminator
- && info->subscript[n]->type == GFC_SS_SCALAR);
- indices[n] = info->subscript[n]->data.scalar.expr;
- break;
-
- case DIMEN_RANGE:
- indices[n] = index;
- break;
-
- case DIMEN_VECTOR:
- index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
-
- indices[n] =
- gfc_trans_array_bound_check (se, info->descriptor, index, n);
- break;
-
- default:
- gcc_unreachable ();
- }
- }
- /* Get the index from the vector. */
- gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
- index = se->expr;
- /* Put the descriptor back. */
- se->expr = descsave;
-
- return index;
-}
-
-
/* Return the offset for an index. Performs bound checking for elemental
dimensions. Single element references are processed separately. */
gfc_array_ref * ar, tree stride)
{
tree index;
+ tree desc;
+ tree data;
/* Get the index into the array for this dimension. */
if (ar)
{
gcc_assert (ar->type != AR_ELEMENT);
- if (ar->dimen_type[dim] == DIMEN_ELEMENT)
+ switch (ar->dimen_type[dim])
{
+ case DIMEN_ELEMENT:
gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
- && info->subscript[dim]->type == GFC_SS_SCALAR);
+ && info->subscript[dim]->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
index = info->subscript[dim]->data.scalar.expr;
index =
gfc_trans_array_bound_check (se, info->descriptor, index, dim);
- }
- else
- {
+ break;
+
+ case DIMEN_VECTOR:
+ gcc_assert (info && se->loop);
+ gcc_assert (info->subscript[dim]
+ && info->subscript[dim]->type == GFC_SS_VECTOR);
+ desc = info->subscript[dim]->data.info.descriptor;
+
+ /* Get a zero-based index into the vector. */
+ index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ se->loop->loopvar[i], se->loop->from[i]);
+
+ /* Multiply the index by the stride. */
+ index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ index, gfc_conv_array_stride (desc, 0));
+
+ /* Read the vector to get an index into info->descriptor. */
+ data = build_fold_indirect_ref (gfc_conv_array_data (desc));
+ index = gfc_build_array_ref (data, index);
+ index = gfc_evaluate_now (index, &se->pre);
+
+ /* Do any bounds checking on the final info->descriptor index. */
+ index = gfc_trans_array_bound_check (se, info->descriptor,
+ index, dim);
+ break;
+
+ case DIMEN_RANGE:
/* Scalarized dimension. */
gcc_assert (info && se->loop);
info->stride[i]);
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]);
+ break;
- if (ar->dimen_type[dim] == DIMEN_VECTOR)
- {
- /* Handle vector subscripts. */
- index = gfc_conv_vector_array_index (se, index,
- info->subscript[dim]);
- index =
- gfc_trans_array_bound_check (se, info->descriptor, index,
- dim);
- }
- else
- gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
+ default:
+ gcc_unreachable ();
}
}
else
dimensions. */
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
- tmp = gfc_build_indirect_ref (info->data);
+ tmp = build_fold_indirect_ref (info->data);
se->expr = gfc_build_array_ref (tmp, index);
}
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
- tmp = gfc_build_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref (tmp);
se->expr = gfc_build_array_ref (tmp, index);
}
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
int dim;
- gfc_ss *vecss;
gfc_expr *end;
tree desc;
tree bound;
gfc_se se;
+ gfc_ss_info *info;
gcc_assert (ss->type == GFC_SS_SECTION);
- /* For vector array subscripts we want the size of the vector. */
- dim = ss->data.info.dim[n];
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- {
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- dim = vecss->data.info.dim[0];
- }
+ info = &ss->data.info;
+ dim = info->dim[n];
+
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ /* We'll calculate the upper bound once we have access to the
+ vector's descriptor. */
+ return NULL;
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
- end = vecss->data.info.ref->u.ar.end[dim];
- desc = vecss->data.info.descriptor;
+ gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+ desc = info->descriptor;
+ end = info->ref->u.ar.end[dim];
if (end)
{
{
gfc_expr *start;
gfc_expr *stride;
- gfc_ss *vecss;
tree desc;
gfc_se se;
gfc_ss_info *info;
int dim;
- info = &ss->data.info;
+ gcc_assert (ss->type == GFC_SS_SECTION);
+ info = &ss->data.info;
dim = info->dim[n];
- /* For vector array subscripts we want the size of the vector. */
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
{
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- /* Get the descriptors for the vector subscripts as well. */
- if (!vecss->data.info.descriptor)
- gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
- dim = vecss->data.info.dim[0];
+ /* We use a zero-based index to access the vector. */
+ info->start[n] = gfc_index_zero_node;
+ info->stride[n] = gfc_index_one_node;
+ return;
}
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
- start = vecss->data.info.ref->u.ar.start[dim];
- stride = vecss->data.info.ref->u.ar.stride[dim];
- desc = vecss->data.info.descriptor;
+ gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+ desc = info->descriptor;
+ start = info->ref->u.ar.start[dim];
+ stride = info->ref->u.ar.stride[dim];
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
int n;
tree tmp;
gfc_ss *ss;
- gfc_ss *vecss;
tree desc;
loop->dimen = 0;
loop->dimen = ss->data.info.dimen;
break;
+ /* As usual, lbound and ubound are exceptions!. */
+ case GFC_SS_INTRINSIC:
+ switch (ss->expr->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ loop->dimen = ss->data.info.dimen;
+
+ default:
+ break;
+ }
+
default:
break;
}
gfc_conv_section_startstride (loop, ss, n);
break;
+ case GFC_SS_INTRINSIC:
+ switch (ss->expr->value.function.isym->generic_id)
+ {
+ /* Fall through to supply start and stride. */
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ break;
+ default:
+ continue;
+ }
+
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
for (n = 0; n < ss->data.info.dimen; n++)
gfc_start_block (&block);
- fault = integer_zero_node;
+ fault = boolean_false_node;
for (n = 0; n < loop->dimen; n++)
size[n] = NULL_TREE;
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
- /* This only checks scalarized dimensions, elemental dimensions are
- checked later. */
+ /* This code only checks ranges. Elemental and vector
+ dimensions are checked later. */
for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
- vecss = ss;
- while (vecss->data.info.ref->u.ar.dimen_type[dim]
- == DIMEN_VECTOR)
- {
- vecss = vecss->data.info.subscript[dim];
- gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
- dim = vecss->data.info.dim[0];
- }
- gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
- == DIMEN_RANGE);
- desc = vecss->data.info.descriptor;
+ if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+ continue;
+
+ desc = ss->data.info.descriptor;
/* Check lower bound. */
bound = gfc_conv_array_lbound (desc, dim);
if (ss->type != GFC_SS_SECTION)
continue;
- if (gfc_could_be_alias (dest, ss))
+ if (gfc_could_be_alias (dest, ss)
+ || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
{
nDepend = 1;
break;
if (nDepend == 1)
{
+ tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
+ if (GFC_ARRAY_TYPE_P (base_type)
+ || GFC_DESCRIPTOR_TYPE_P (base_type))
+ base_type = gfc_get_element_type (base_type);
loop->temp_ss = gfc_get_ss ();
loop->temp_ss->type = GFC_SS_TEMP;
- loop->temp_ss->data.temp.type =
- gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
+ loop->temp_ss->data.temp.type = base_type;
loop->temp_ss->string_length = dest->string_length;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
- gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
- tmp, false);
+ gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
+ &loop->temp_ss->data.info, tmp, false, true,
+ false);
}
for (n = 0; n < loop->temp_dim; n++)
tree size;
tree offset;
tree stride;
+ tree cond;
+ tree or_expr;
+ tree thencase;
+ tree elsecase;
+ tree var;
+ stmtblock_t thenblock;
+ stmtblock_t elseblock;
gfc_expr *ubound;
gfc_se se;
int n;
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ or_expr = NULL_TREE;
+
for (n = 0; n < rank; n++)
{
/* We have 3 possibilities for determining the size of the array:
/* Calculate the size of this dimension. */
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
+ /* Check wether the size for this dimension is negative. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, size,
+ gfc_index_zero_node);
+ if (n == 0)
+ or_expr = cond;
+ else
+ or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
+
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
stride = gfc_evaluate_now (stride, pblock);
*poffset = offset;
}
- size = gfc_evaluate_now (size, pblock);
- return size;
+ var = gfc_create_var (TREE_TYPE (size), "size");
+ gfc_start_block (&thenblock);
+ gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
+ thencase = gfc_finish_block (&thenblock);
+
+ gfc_start_block (&elseblock);
+ gfc_add_modify_expr (&elseblock, var, size);
+ elsecase = gfc_finish_block (&elseblock);
+
+ tmp = gfc_evaluate_now (or_expr, pblock);
+ tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+ gfc_add_expr_to_block (pblock, tmp);
+
+ return var;
}
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
-void
-gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
+bool
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
{
tree tmp;
tree pointer;
tree size;
gfc_expr **lower;
gfc_expr **upper;
+ gfc_ref *ref;
+ int allocatable_array;
+ int must_be_pointer;
+
+ ref = expr->ref;
+
+ /* In Fortran 95, components can only contain pointers, so that,
+ in ALLOCATE (foo%bar(2)), bar must be a pointer component.
+ We test this by checking for ref->next.
+ An implementation of TR 15581 would need to change this. */
+
+ if (ref)
+ must_be_pointer = ref->next != NULL;
+ else
+ must_be_pointer = 0;
+
+ /* Find the last reference in the chain. */
+ while (ref && ref->next != NULL)
+ {
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ ref = ref->next;
+ }
+
+ if (ref == NULL || ref->type != REF_ARRAY)
+ return false;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
tmp = gfc_conv_descriptor_data_addr (se->expr);
pointer = gfc_evaluate_now (tmp, &se->pre);
+ if (must_be_pointer)
+ allocatable_array = 0;
+ else
+ allocatable_array = expr->symtree->n.sym->attr.allocatable;
+
if (TYPE_PRECISION (gfc_array_index_type) == 32)
- allocate = gfor_fndecl_allocate;
+ {
+ if (allocatable_array)
+ allocate = gfor_fndecl_allocate_array;
+ else
+ allocate = gfor_fndecl_allocate;
+ }
else if (TYPE_PRECISION (gfc_array_index_type) == 64)
- allocate = gfor_fndecl_allocate64;
+ {
+ if (allocatable_array)
+ allocate = gfor_fndecl_allocate64_array;
+ else
+ allocate = gfor_fndecl_allocate64;
+ }
else
gcc_unreachable ();
tmp = gfc_chainon_list (NULL_TREE, pointer);
tmp = gfc_chainon_list (tmp, size);
tmp = gfc_chainon_list (tmp, pstat);
- tmp = gfc_build_function_call (allocate, tmp);
+ tmp = build_function_call_expr (allocate, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_add_modify_expr (&se->pre, tmp, offset);
+
+ return true;
}
/* Parameter is the address of the data component. */
tmp = gfc_chainon_list (NULL_TREE, var);
tmp = gfc_chainon_list (tmp, pstat);
- tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
if (dim + 1 < as->rank)
stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
else
- stride = NULL_TREE;
+ stride = GFC_TYPE_ARRAY_SIZE (type);
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
{
size = stride;
}
+ gfc_trans_vla_type_sizes (sym, pblock);
+
*poffset = offset;
return size;
}
{
gfc_trans_init_string_length (sym->ts.cl, &block);
+ gfc_trans_vla_type_sizes (sym, &block);
+
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
+ /* Don't actually allocate space for Cray Pointees. */
+ if (sym->attr.cray_pointee)
+ {
+ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+ gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_expr_to_block (&block, fnbody);
+ return gfc_finish_block (&block);
+ }
+
/* The size is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
fndecl = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
- tmp = gfc_build_function_call (fndecl, tmp);
+ tmp = build_function_call_expr (fndecl, tmp);
tmp = fold (convert (TREE_TYPE (decl), tmp));
gfc_add_modify_expr (&block, decl, tmp);
/* Free the temporary. */
tmp = convert (pvoid_type_node, decl);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
type = TREE_TYPE (tmpdesc);
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- dumdesc = gfc_build_indirect_ref (dumdesc);
+ dumdesc = build_fold_indirect_ref (dumdesc);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
partial = gfc_create_var (boolean_type_node, "partial");
TREE_USED (partial) = 1;
tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
gfc_add_modify_expr (&block, partial, tmp);
}
else
stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
stride = gfc_evaluate_now (stride, &block);
- tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
+ tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
/* A library call to repack the array if necessary. */
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
+ stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
stride = gfc_index_one_node;
}
if (!INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->upper[n],
+ gfc_conv_expr_type (&se, sym->as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify_expr (&block, lbound, se.expr);
gfc_add_modify_expr (&block, stride, tmp);
}
}
+ else
+ {
+ stride = GFC_TYPE_ARRAY_SIZE (type);
+
+ if (stride && !INTEGER_CST_P (stride))
+ {
+ /* Calculate size = stride * (ubound + 1 - lbound). */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, lbound);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ ubound, tmp);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+ gfc_add_modify_expr (&block, stride, tmp);
+ }
+ }
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_trans_vla_type_sizes (sym, &block);
+
stmt = gfc_finish_block (&block);
gfc_start_block (&block);
/* Copy the data back. */
tmp = gfc_chainon_list (NULL_TREE, dumdesc);
tmp = gfc_chainon_list (tmp, tmpdesc);
- tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
}
/* Free the temporary. */
tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
stmt = gfc_finish_block (&cleanup);
/* Only do the cleanup if the array was repacked. */
- tmp = gfc_build_indirect_ref (dumdesc);
+ tmp = build_fold_indirect_ref (dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
-/* Convert an array for passing as an actual parameter. Expressions and
+/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
a modified copy of the descriptor is passed, but using the original data.
- Also used for array pointer assignments by setting se->direct_byref. */
+
+ This function is also used for array pointer assignments, and there
+ are three cases:
+
+ - want_pointer && !se->direct_byref
+ EXPR is an actual argument. On exit, se->expr contains a
+ pointer to the array descriptor.
+
+ - !want_pointer && !se->direct_byref
+ EXPR is an actual argument to an intrinsic function or the
+ left-hand side of a pointer assignment. On exit, se->expr
+ contains the descriptor for EXPR.
+
+ - !want_pointer && se->direct_byref
+ EXPR is the right-hand side of a pointer assignment and
+ se->expr is the descriptor for the previously-evaluated
+ left-hand side. The function creates an assignment from
+ EXPR to se->expr. */
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
tree start;
tree offset;
int full;
- gfc_ss *vss;
gfc_ref *ref;
gcc_assert (ss != gfc_ss_terminator);
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
-
- need_tmp = 0;
- for (n = 0; n < secss->data.info.dimen; n++)
- {
- vss = secss->data.info.subscript[secss->data.info.dim[n]];
- if (vss && vss->type == GFC_SS_VECTOR)
- need_tmp = 1;
- }
-
info = &secss->data.info;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
- if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+
+ need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+ if (need_tmp)
+ full = 0;
+ else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
}
}
- /* Check for substring references. */
- ref = expr->ref;
- if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
- {
- while (ref->next)
- ref = ref->next;
- if (ref->type == REF_SUBSTRING)
- {
- /* In general character substrings need a copy. Character
- array strides are expressed as multiples of the element
- size (consistent with other array types), not in
- characters. */
- full = 0;
- need_tmp = 1;
- }
- }
-
if (full)
{
if (se->direct_byref)
{
/* We pass full arrays directly. This means that pointers and
allocatable arrays should also work. */
- se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+ se->expr = build_fold_addr_expr (desc);
}
else
{
/* For pointer assignments pass the descriptor directly. */
se->ss = secss;
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
gfc_conv_expr (se, expr);
return;
}
if (!need_tmp)
loop.array_parameter = 1;
else
- gcc_assert (se->want_pointer && !se->direct_byref);
+ /* The right-hand side of a pointer assignment mustn't use a temporary. */
+ gcc_assert (!se->direct_byref);
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
loop.temp_ss->next = gfc_ss_terminator;
if (expr->ts.type == BT_CHARACTER)
{
- gcc_assert (expr->ts.cl && expr->ts.cl->length
- && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
- loop.temp_ss->string_length = gfc_conv_mpz_to_tree
- (expr->ts.cl->length->value.integer,
- expr->ts.cl->length->ts.kind);
- expr->ts.cl->backend_decl = loop.temp_ss->string_length;
- }
- loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-
- /* ... which can hold our string, if present. */
- if (expr->ts.type == BT_CHARACTER)
- {
- loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+ if (expr->ts.cl
+ && expr->ts.cl->length
+ && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ expr->ts.cl->backend_decl
+ = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
+ expr->ts.cl->length->ts.kind);
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length
+ = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+ }
+ else
+ {
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ }
se->string_length = loop.temp_ss->string_length;
}
else
- loop.temp_ss->string_length = NULL;
+ {
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = NULL;
+ }
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_expr (&rse, expr);
- rse.expr = gfc_build_indirect_ref (rse.expr);
+ if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+ rse.expr = build_fold_indirect_ref (rse.expr);
}
else
gfc_conv_expr_val (&rse, expr);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
- /* Set the first stride component to zero to indicate a temporary. */
desc = loop.temp_ss->data.info.descriptor;
- tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
gcc_assert (is_gimple_lvalue (desc));
- se->expr = gfc_build_addr_expr (NULL, desc);
}
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
-
- if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL_TREE, desc);
- else
- se->expr = desc;
-
- if (expr->ts.type == BT_CHARACTER)
- se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+ se->string_length = ss->string_length;
}
else
{
/* Set the new lower bound. */
from = loop.from[dim];
to = loop.to[dim];
- if (!integer_onep (from))
+
+ /* If we have an array section or are assigning to a pointer,
+ make sure that the lower bound is 1. References to the full
+ array should otherwise keep the original bounds. */
+ if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
+ && !integer_onep (from))
{
- /* Make sure the new section starts at 1. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, from);
to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
dim++;
}
- /* Point the data pointer at the first element in the section. */
- tmp = gfc_conv_array_data (desc);
- tmp = gfc_build_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, offset);
- offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
- gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
+ if (se->data_not_needed)
+ gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
+ else
+ {
+ /* Point the data pointer at the first element in the section. */
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_build_array_ref (tmp, offset);
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
+ }
- if (se->direct_byref)
+ if (se->direct_byref && !se->data_not_needed)
{
/* Set the offset. */
tmp = gfc_conv_descriptor_offset (parm);
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
}
+ desc = parm;
+ }
- if (!se->direct_byref)
- {
- /* Get a pointer to the new descriptor. */
- if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL, parm);
- else
- se->expr = parm;
- }
+ if (!se->direct_byref)
+ {
+ /* Get a pointer to the new descriptor. */
+ if (se->want_pointer)
+ se->expr = build_fold_addr_expr (desc);
+ else
+ se->expr = desc;
}
gfc_add_block_to_block (&se->pre, &loop.pre);
{
sym = expr->symtree->n.sym;
tmp = gfc_get_symbol_decl (sym);
+
if (sym->ts.type == BT_CHARACTER)
se->string_length = sym->ts.cl->backend_decl;
if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
se->expr = tmp;
else
- se->expr = gfc_build_addr_expr (NULL, tmp);
+ se->expr = build_fold_addr_expr (tmp);
return;
}
if (sym->attr.allocatable)
desc = se->expr;
/* Repack the array. */
tmp = gfc_chainon_list (NULL_TREE, desc);
- ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
+ ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
ptr = gfc_evaluate_now (ptr, &se->pre);
se->expr = ptr;
/* Copy the data back. */
tmp = gfc_chainon_list (NULL_TREE, desc);
tmp = gfc_chainon_list (tmp, ptr);
- tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&block, tmp);
/* Free the temporary. */
tmp = convert (pvoid_type_node, ptr);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
gfc_init_block (&block);
/* Only if it was repacked. This code needs to be executed before the
loop cleanup code. */
- tmp = gfc_build_indirect_ref (desc);
+ tmp = build_fold_indirect_ref (desc);
tmp = gfc_conv_array_data (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
+/* Generate code to deallocate an array, if it is allocated. */
+
+tree
+gfc_trans_dealloc_allocated (tree descriptor)
+{
+ tree tmp;
+ tree deallocate;
+ stmtblock_t block;
+
+ gfc_start_block (&block);
+ deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
+
+ tmp = gfc_conv_descriptor_data_get (descriptor);
+ tmp = build2 (NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
+
+ tmp = gfc_finish_block (&block);
+
+ return tmp;
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
tree
tree type;
tree tmp;
tree descriptor;
- tree deallocate;
- stmtblock_t block;
stmtblock_t fnblock;
locus loc;
gfc_init_block (&fnblock);
- gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
+ gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
+ || TREE_CODE (sym->backend_decl) == PARM_DECL);
+
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ {
+ gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ gfc_trans_vla_type_sizes (sym, &fnblock);
+ }
/* Dummy and use associated variables don't need anything special. */
if (sym->attr.dummy || sym->attr.use_assoc)
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ /* If the backend_decl is not a descriptor, we must have a pointer
+ to one. */
+ descriptor = build_fold_indirect_ref (sym->backend_decl);
+ type = TREE_TYPE (descriptor);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ }
/* NULLIFY the data pointer. */
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
/* Allocatable arrays need to be freed when they go out of scope. */
if (sym->attr.allocatable)
{
- gfc_start_block (&block);
-
- /* Deallocate if still allocated at the end of the procedure. */
- deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
-
- tmp = gfc_conv_descriptor_data_get (descriptor);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
-
- tmp = gfc_finish_block (&block);
+ tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
case DIMEN_VECTOR:
- /* Get a SS for the vector. This will not be added to the
- chain directly. */
- indexss = gfc_walk_expr (ar->start[n]);
- if (indexss == gfc_ss_terminator)
- internal_error ("scalar vector subscript???");
-
- /* We currently only handle really simple vector
- subscripts. */
- if (indexss->next != gfc_ss_terminator)
- gfc_todo_error ("vector subscript expressions");
- indexss->loop_chain = gfc_ss_terminator;
-
- /* Mark this as a vector subscript. We don't add this
- directly into the chain, but as a subscript of the
- existing SS for this term. */
+ /* Create a GFC_SS_VECTOR index in which we can store
+ the vector's descriptor. */
+ indexss = gfc_get_ss ();
indexss->type = GFC_SS_VECTOR;
+ indexss->expr = ar->start[n];
+ indexss->next = gfc_ss_terminator;
+ indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
- /* Also remember this dimension. */
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
/* Reverse a SS chain. */
-static gfc_ss *
+gfc_ss *
gfc_reverse_ss (gfc_ss * ss)
{
gfc_ss *next;
/* Walk the arguments of an elemental function. */
gfc_ss *
-gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
+gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gfc_ss_type type)
{
- gfc_actual_arglist *arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
head = gfc_ss_terminator;
tail = NULL;
scalar = 1;
- for (arg = expr->value.function.actual; arg; arg = arg->next)
+ for (; arg; arg = arg->next)
{
if (!arg->expr)
continue;
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
if (sym->attr.elemental)
- return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
+ return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+ GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
res = gfc_walk_subexpr (gfc_ss_terminator, expr);
return gfc_reverse_ss (res);
}
-
OSDN Git Service
