/* 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
/* 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
static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
- gfc_ss_info * info, tree size, tree nelem,
- bool dynamic)
+ gfc_ss_info * info, tree size, tree nelem,
+ bool dynamic, bool dealloc)
{
tree tmp;
tree args;
{
/* 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);
+ 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 = build_function_call_expr (tmp, args);
tmp = gfc_evaluate_now (tmp, pre);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
tmp = gfc_conv_descriptor_offset (desc);
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);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (post, tmp);
}
}
-/* Generate code to allocate and initialize the descriptor for a temporary
+/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
- functions returning arrays. Adjusts the loop variables to be zero-based,
- and calculates the loop bounds for callee allocated arrays.
- Also fills in the descriptor, data and offset fields of info if known.
- Returns the size of the array, or NULL for a callee allocated array.
+ functions returning arrays. Adjusts the loop variables to be
+ zero-based, and calculates the loop bounds for callee allocated arrays.
+ Allocate the array unless it's callee allocated (we have a callee
+ allocated array if 'callee_alloc' is true, or if loop->to[n] is
+ NULL_TREE for any n). Also fills in the descriptor, data and offset
+ fields of info if known. Returns the size of the array, or NULL for a
+ callee allocated array.
- PRE, POST and DYNAMIC are 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 (stmtblock_t * pre, stmtblock_t * post,
- 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;
/* 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 (pre, post, 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 tranpose array EXPR by creating a new descriptor
+/* Generate code to transpose array EXPR by creating a new descriptor
in which the dimension specifications have been reversed. */
void
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);
/* Copy the dimension information, renumbering dimension 1 to 0 and
0 to 1. */
- gcc_assert (dest_info->dimen == 2);
- gcc_assert (src_info->dimen == 2);
for (n = 0; n < 2; n++)
{
- dest_info->delta[n] = integer_zero_node;
- dest_info->start[n] = integer_zero_node;
- dest_info->stride[n] = integer_one_node;
+ 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];
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->pre, &loop->post, 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;
else
{
/* Descriptorless arrays. */
- return gfc_build_addr_expr (NULL, descriptor);
+ return build_fold_addr_expr (descriptor);
}
}
else
index, gfc_conv_array_stride (desc, 0));
/* Read the vector to get an index into info->descriptor. */
- data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
+ data = build_fold_indirect_ref (gfc_conv_array_data (desc));
index = gfc_build_array_ref (data, index);
index = gfc_evaluate_now (index, &se->pre);
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);
}
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;
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;
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->pre, &loop->post, 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);
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;
}
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 ());
{
/* 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;
}
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));
}
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);
{
/* Get a pointer to the new descriptor. */
if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL, desc);
+ se->expr = build_fold_addr_expr (desc);
else
se->expr = desc;
}
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;
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);
}
/* 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. */
OSDN Git Service
