/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
return t;
}
-/* This provides WRITE access to the data field. */
+/* This provides WRITE access to the data field.
+
+ TUPLES_P is true if we are generating tuples.
+
+ This function gets called through the following macros:
+ gfc_conv_descriptor_data_set
+ gfc_conv_descriptor_data_set_tuples. */
void
-gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
+gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
+ tree desc, tree value,
+ bool tuples_p)
{
tree field, type, t;
gcc_assert (DATA_FIELD == 0);
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
}
bool dynamic, bool dealloc)
{
tree tmp;
- tree args;
tree desc;
bool onstack;
else
{
/* Allocate memory to hold the data. */
- args = gfc_chainon_list (NULL_TREE, size);
-
- if (gfc_index_integer_kind == 4)
- tmp = gfor_fndecl_internal_malloc;
- else if (gfc_index_integer_kind == 8)
- tmp = gfor_fndecl_internal_malloc64;
- else
- gcc_unreachable ();
- tmp = build_function_call_expr (tmp, args);
+ tmp = gfc_call_malloc (pre, NULL, size);
tmp = gfc_evaluate_now (tmp, pre);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
{
/* 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 = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
gfc_add_expr_to_block (post, tmp);
}
}
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, bool function)
+ bool callee_alloc)
{
tree type;
tree desc;
tree nelem;
tree cond;
tree or_expr;
- tree thencase;
- tree elsecase;
- tree var;
- stmtblock_t thenblock;
- stmtblock_t elseblock;
int n;
int dim;
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;
info->dim[dim] = dim;
}
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
- if (function)
- {
- /* Check wether the size for this dimension is negative. */
- cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
+ /* Check whether the size for this dimension is negative. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
gfc_index_zero_node);
+ cond = gfc_evaluate_now (cond, pre);
- cond = gfc_evaluate_now (cond, pre);
+ if (n == 0)
+ or_expr = cond;
+ else
+ or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
- if (n == 0)
- or_expr = cond;
- else
- or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
- }
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
size = gfc_evaluate_now (size, pre);
}
if (size && !callee_alloc)
{
- if (function)
- {
- 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, pre);
- tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
- gfc_add_expr_to_block (pre, tmp);
- nelem = var;
- size = var;
- }
- else
- nelem = size;
+ /* 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 (COND_EXPR, gfc_array_index_type,
+ or_expr, gfc_index_zero_node, size);
+ nelem = size;
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
}
{
dest_info->delta[n] = gfc_index_zero_node;
dest_info->start[n] = gfc_index_zero_node;
+ dest_info->end[n] = gfc_index_zero_node;
dest_info->stride[n] = gfc_index_one_node;
dest_info->dim[n] = n;
static void
gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
{
- tree args;
+ tree arg0, arg1;
tree tmp;
tree size;
tree ubound;
gfc_add_modify_expr (pblock, ubound, tmp);
/* Get the value of the current data pointer. */
- tmp = gfc_conv_descriptor_data_get (desc);
- args = gfc_chainon_list (NULL_TREE, tmp);
+ arg0 = gfc_conv_descriptor_data_get (desc);
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
- tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
- args = gfc_chainon_list (args, tmp);
+ arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
/* Pick the appropriate realloc function. */
if (gfc_index_integer_kind == 4)
gcc_unreachable ();
/* Set the new data pointer. */
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_call_expr (tmp, 2, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
- tree args;
gfc_conv_expr (se, expr);
tmp = gfc_build_addr_expr (pchar_type_node, tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- args = gfc_chainon_list (NULL_TREE, tmp);
- args = gfc_chainon_list (args, se->expr);
- args = gfc_chainon_list (args, se->string_length);
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp, se->expr, se->string_length);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
+ TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
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 = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
- tmp);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp, init, bound);
gfc_add_expr_to_block (&body, tmp);
*poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
return is_const;
}
+/* Check whether the array constructor C consists entirely of constant
+ elements, and if so returns the number of those elements, otherwise
+ return zero. Note, an empty or NULL array constructor returns zero. */
+
+unsigned HOST_WIDE_INT
+gfc_constant_array_constructor_p (gfc_constructor * c)
+{
+ unsigned HOST_WIDE_INT nelem = 0;
+
+ while (c)
+ {
+ if (c->iterator
+ || c->expr->rank > 0
+ || c->expr->expr_type != EXPR_CONSTANT)
+ return 0;
+ c = c->next;
+ nelem++;
+ }
+ return nelem;
+}
+
+
+/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
+ and the tree type of it's elements, TYPE, return a static constant
+ variable that is compile-time initialized. */
+
+tree
+gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
+{
+ tree tmptype, list, init, tmp;
+ HOST_WIDE_INT nelem;
+ gfc_constructor *c;
+ gfc_array_spec as;
+ gfc_se se;
+ int i;
+
+ /* First traverse the constructor list, converting the constants
+ to tree to build an initializer. */
+ nelem = 0;
+ list = NULL_TREE;
+ c = expr->value.constructor;
+ while (c)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, c->expr);
+ if (c->expr->ts.type == BT_CHARACTER
+ && POINTER_TYPE_P (type))
+ se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+ list = tree_cons (NULL_TREE, se.expr, list);
+ c = c->next;
+ nelem++;
+ }
+
+ /* Next determine the tree type for the array. We use the gfortran
+ front-end's gfc_get_nodesc_array_type in order to create a suitable
+ GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
+
+ memset (&as, 0, sizeof (gfc_array_spec));
+
+ as.rank = expr->rank;
+ as.type = AS_EXPLICIT;
+ if (!expr->shape)
+ {
+ as.lower[0] = gfc_int_expr (0);
+ as.upper[0] = gfc_int_expr (nelem - 1);
+ }
+ else
+ for (i = 0; i < expr->rank; i++)
+ {
+ int tmp = (int) mpz_get_si (expr->shape[i]);
+ as.lower[i] = gfc_int_expr (0);
+ as.upper[i] = gfc_int_expr (tmp - 1);
+ }
+
+ tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
+
+ init = build_constructor_from_list (tmptype, nreverse (list));
+
+ TREE_CONSTANT (init) = 1;
+ TREE_INVARIANT (init) = 1;
+ TREE_STATIC (init) = 1;
+
+ tmp = gfc_create_var (tmptype, "A");
+ TREE_STATIC (tmp) = 1;
+ TREE_CONSTANT (tmp) = 1;
+ TREE_INVARIANT (tmp) = 1;
+ TREE_READONLY (tmp) = 1;
+ DECL_INITIAL (tmp) = init;
+
+ return tmp;
+}
+
+
+/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
+ This mostly initializes the scalarizer state info structure with the
+ appropriate values to directly use the array created by the function
+ gfc_build_constant_array_constructor. */
+
+static void
+gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
+ gfc_ss * ss, tree type)
+{
+ gfc_ss_info *info;
+ tree tmp;
+ int i;
+
+ tmp = gfc_build_constant_array_constructor (ss->expr, type);
+
+ info = &ss->data.info;
+
+ info->descriptor = tmp;
+ info->data = build_fold_addr_expr (tmp);
+ info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
+ loop->from[0]);
+
+ for (i = 0; i < info->dimen; i++)
+ {
+ info->delta[i] = gfc_index_zero_node;
+ info->start[i] = gfc_index_zero_node;
+ info->end[i] = gfc_index_zero_node;
+ info->stride[i] = gfc_index_one_node;
+ info->dim[i] = i;
+ }
+
+ if (info->dimen > loop->temp_dim)
+ loop->temp_dim = info->dimen;
+}
+
+/* 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 gfc_trans_constant_array_constructor. Returns the
+ the iteration count of the loop if suitable, and NULL_TREE otherwise. */
+
+static tree
+constant_array_constructor_loop_size (gfc_loopinfo * loop)
+{
+ tree size = gfc_index_one_node;
+ tree tmp;
+ int i;
+
+ for (i = 0; i < loop->dimen; i++)
+ {
+ /* 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]))
+ {
+ /* Only allow non-zero "from" in one-dimensional arrays. */
+ if (loop->dimen != 1)
+ return NULL_TREE;
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ loop->to[i], loop->from[i]);
+ }
+ else
+ tmp = loop->to[i];
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ }
+
+ return size;
+}
+
/* Array constructors are handled by constructing a temporary, then using that
within the scalarization loop. This is not optimal, but seems by far the
tree offsetvar;
tree desc;
tree type;
- bool const_string;
bool dynamic;
ss->data.info.dimen = loop->dimen;
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- const_string = get_array_ctor_strlen (c, &ss->string_length);
+ bool const_string = get_array_ctor_strlen (c, &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
type = build_pointer_type (type);
}
else
- {
- const_string = TRUE;
- type = gfc_typenode_for_spec (&ss->expr->ts);
- }
+ type = gfc_typenode_for_spec (&ss->expr->ts);
/* See if the constructor determines the loop bounds. */
dynamic = false;
mpz_clear (size);
}
+ /* Special case constant array constructors. */
+ if (!dynamic)
+ {
+ unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
+ if (nelem > 0)
+ {
+ tree size = constant_array_constructor_loop_size (loop);
+ if (size && compare_tree_int (size, nelem) == 0)
+ {
+ gfc_trans_constant_array_constructor (loop, ss, type);
+ return;
+ }
+ }
+ }
+
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
- type, dynamic, true, false, false);
+ type, dynamic, true, false);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
/* Multiply the loop variable by the stride and delta. */
index = se->loop->loopvar[i];
- index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
- info->stride[i]);
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
- info->delta[i]);
+ if (!integer_onep (info->stride[i]))
+ index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
+ info->stride[i]);
+ if (!integer_zerop (info->delta[i]))
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
+ info->delta[i]);
break;
default:
}
/* Multiply by the stride. */
- index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
+ if (!integer_onep (stride))
+ index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
return index;
}
info->stride0);
/* Add the offset for this dimension to the stored offset for all other
dimensions. */
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
+ if (!integer_zerop (info->offset))
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
tmp = build_fold_indirect_ref (info->data);
se->expr = gfc_build_array_ref (tmp, index);
tree cond;
char *msg;
- indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
-
tmp = gfc_conv_array_lbound (se->expr, n);
cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp);
gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
{
gfc_expr *start;
+ gfc_expr *end;
gfc_expr *stride;
tree desc;
gfc_se se;
{
/* We use a zero-based index to access the vector. */
info->start[n] = gfc_index_zero_node;
+ info->end[n] = gfc_index_zero_node;
info->stride[n] = gfc_index_one_node;
return;
}
gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
desc = info->descriptor;
start = info->ref->u.ar.start[dim];
+ end = info->ref->u.ar.end[dim];
stride = info->ref->u.ar.stride[dim];
/* Calculate the start of the range. For vector subscripts this will
}
info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
+ /* Similarly calculate the end. Although this is not used in the
+ scalarizer, it is needed when checking bounds and where the end
+ is an expression with side-effects. */
+ if (end)
+ {
+ /* Specified section start. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, end, gfc_array_index_type);
+ gfc_add_block_to_block (&loop->pre, &se.pre);
+ info->end[n] = se.expr;
+ }
+ else
+ {
+ /* No upper bound specified so use the bound of the array. */
+ info->end[n] = gfc_conv_array_ubound (desc, dim);
+ }
+ info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
+
/* Calculate the stride. */
if (stride == NULL)
info->stride[n] = gfc_index_one_node;
for (n = 0; n < ss->data.info.dimen; n++)
{
ss->data.info.start[n] = gfc_index_zero_node;
+ ss->data.info.end[n] = gfc_index_zero_node;
ss->data.info.stride[n] = gfc_index_one_node;
}
break;
than it is here, with all the trees. */
lbound = gfc_conv_array_lbound (desc, dim);
ubound = gfc_conv_array_ubound (desc, dim);
- end = gfc_conv_section_upper_bound (ss, n, &block);
+ end = info->end[n];
/* Zero stride is not allowed. */
tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
rref = ss->expr->ref;
nDepend = gfc_dep_resolver (lref, rref);
+ if (nDepend == 1)
+ break;
#if 0
/* TODO : loop shifting. */
if (nDepend == 1)
loop->temp_ss->data.info.dimen = n;
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
&loop->temp_ss->data.info, tmp, false, true,
- false, false);
+ false);
}
for (n = 0; n < loop->temp_dim; n++)
{
/* Calculate the offset relative to the loop variable.
First multiply by the stride. */
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- loop->from[n], info->stride[n]);
+ tmp = loop->from[n];
+ if (!integer_onep (info->stride[n]))
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, info->stride[n]);
/* Then subtract this from our starting value. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
/* 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. */
+ /* Check whether the size for this dimension is negative. */
cond = fold_build2 (LE_EXPR, boolean_type_node, size,
gfc_index_zero_node);
if (n == 0)
*poffset = offset;
}
+ if (integer_zerop (or_expr))
+ return size;
+ if (integer_onep (or_expr))
+ return gfc_index_zero_node;
+
var = gfc_create_var (TREE_TYPE (size), "size");
gfc_start_block (&thenblock);
gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
lower, upper, &se->pre);
/* Allocate memory to store the data. */
- tmp = gfc_conv_descriptor_data_addr (se->expr);
- pointer = gfc_evaluate_now (tmp, &se->pre);
+ pointer = gfc_conv_descriptor_data_get (se->expr);
+ STRIP_NOPS (pointer);
if (TYPE_PRECISION (gfc_array_index_type) == 32)
{
else
gcc_unreachable ();
- tmp = gfc_chainon_list (NULL_TREE, pointer);
- tmp = gfc_chainon_list (tmp, size);
- tmp = gfc_chainon_list (tmp, pstat);
- tmp = build_function_call_expr (allocate, tmp);
+ /* The allocate_array variants take the old pointer as first argument. */
+ if (allocatable_array)
+ tmp = build_call_expr (allocate, 3, pointer, size, pstat);
+ else
+ tmp = build_call_expr (allocate, 2, size, pstat);
+ tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_start_block (&block);
/* Get a pointer to the data. */
- tmp = gfc_conv_descriptor_data_addr (descriptor);
- var = gfc_evaluate_now (tmp, &block);
+ var = gfc_conv_descriptor_data_get (descriptor);
+ STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = gfc_chainon_list (NULL_TREE, var);
- tmp = gfc_chainon_list (tmp, pstat);
- tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
+ tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Zero the data pointer. */
+ tmp = build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
stmtblock_t block;
tree type;
tree tmp;
- tree fndecl;
tree size;
tree offset;
bool onstack;
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
/* Allocate memory to hold the data. */
- tmp = gfc_chainon_list (NULL_TREE, size);
-
- if (gfc_index_integer_kind == 4)
- fndecl = gfor_fndecl_internal_malloc;
- else if (gfc_index_integer_kind == 8)
- fndecl = gfor_fndecl_internal_malloc64;
- else
- gcc_unreachable ();
- tmp = build_function_call_expr (fndecl, tmp);
- tmp = fold (convert (TREE_TYPE (decl), tmp));
+ tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
gfc_add_modify_expr (&block, decl, tmp);
/* Set offset of the array. */
gfc_add_expr_to_block (&block, fnbody);
/* Free the temporary. */
- tmp = convert (pvoid_type_node, decl);
- tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ tmp = gfc_call_free (convert (pvoid_type_node, decl));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
locus loc;
tree offset;
tree tmp;
+ tree stmt;
stmtblock_t block;
gfc_get_backend_locus (&loc);
tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
gfc_add_modify_expr (&block, parm, tmp);
}
- tmp = gfc_finish_block (&block);
+ stmt = gfc_finish_block (&block);
gfc_set_backend_locus (&loc);
gfc_start_block (&block);
+
/* Add the initialization code to the start of the function. */
- gfc_add_expr_to_block (&block, tmp);
+
+ if (sym->attr.optional || sym->attr.not_always_present)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ }
+
+ gfc_add_expr_to_block (&block, stmt);
gfc_add_expr_to_block (&block, body);
return gfc_finish_block (&block);
gcc_assert (integer_onep (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 = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+ stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
stride = gfc_index_one_node;
}
if (sym->attr.intent != INTENT_IN)
{
/* Copy the data back. */
- tmp = gfc_chainon_list (NULL_TREE, dumdesc);
- tmp = gfc_chainon_list (tmp, tmpdesc);
- tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
+ tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
gfc_add_expr_to_block (&cleanup, tmp);
}
/* Free the temporary. */
- tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ tmp = gfc_call_free (tmpdesc);
gfc_add_expr_to_block (&cleanup, tmp);
stmt = gfc_finish_block (&cleanup);
tree start;
tree offset;
int full;
- gfc_ref *ref;
gcc_assert (ss != gfc_ss_terminator);
- /* TODO: Pass constant array constructors without a temporary. */
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
else if (se->direct_byref)
full = 0;
else
- {
- ref = info->ref;
- gcc_assert (ref->u.ar.type == AR_SECTION);
-
- full = 1;
- for (n = 0; n < ref->u.ar.dimen; n++)
- {
- /* Detect passing the full array as a section. This could do
- even more checking, but it doesn't seem worth it. */
- if (ref->u.ar.start[n]
- || ref->u.ar.end[n]
- || (ref->u.ar.stride[n]
- && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
- {
- full = 0;
- break;
- }
- }
- }
+ full = gfc_full_array_ref_p (info->ref);
if (full)
{
}
break;
+ case EXPR_ARRAY:
+ /* Constant array constructors don't need a temporary. */
+ if (ss->type == GFC_SS_CONSTRUCTOR
+ && expr->ts.type != BT_CHARACTER
+ && gfc_constant_array_constructor_p (expr->value.constructor))
+ {
+ need_tmp = 0;
+ info = &ss->data.info;
+ secss = ss;
+ }
+ else
+ {
+ need_tmp = 1;
+ secss = NULL;
+ info = NULL;
+ }
+ break;
+
default:
/* Something complicated. Copy it into a temporary. */
need_tmp = 1;
limits will be the limits of the section.
A function may decide to repack the array to speed up access, but
we're not bothered about that here. */
- int dim;
+ int dim, ndim;
tree parm;
tree parmtype;
tree stride;
else
base = NULL_TREE;
- for (n = 0; n < info->ref->u.ar.dimen; n++)
+ ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
+ for (n = 0; n < ndim; n++)
{
stride = gfc_conv_array_stride (desc, n);
/* Work out the offset. */
- if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
gcc_assert (info->subscript[n]
&& info->subscript[n]->type == GFC_SS_SCALAR);
tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
- if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
/* For elemental dimensions, we only need the offset. */
continue;
}
/* Vector subscripts need copying and are handled elsewhere. */
- gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+ if (info->ref)
+ gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
/* Set the new lower bound. */
from = loop.from[dim];
/* 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)
+ if ((!info->ref
+ || info->ref->u.ar.type != AR_FULL
+ || se->direct_byref)
&& !integer_onep (from))
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
tree desc;
tree tmp;
tree stmt;
+ tree parent = DECL_CONTEXT (current_function_decl);
+ bool full_array_var, this_array_result;
gfc_symbol *sym;
stmtblock_t block;
+ full_array_var = (expr->expr_type == EXPR_VARIABLE
+ && expr->ref->u.ar.type == AR_FULL);
+ sym = full_array_var ? expr->symtree->n.sym : NULL;
+
+ /* Is this the result of the enclosing procedure? */
+ this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
+ if (this_array_result
+ && (sym->backend_decl != current_function_decl)
+ && (sym->backend_decl != parent))
+ this_array_result = false;
+
/* Passing address of the array if it is not pointer or assumed-shape. */
- if (expr->expr_type == EXPR_VARIABLE
- && expr->ref->u.ar.type == AR_FULL && g77)
+ if (full_array_var && g77 && !this_array_result)
{
- sym = expr->symtree->n.sym;
tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
}
}
- se->want_pointer = 1;
- gfc_conv_expr_descriptor (se, expr, ss);
+ if (this_array_result)
+ {
+ /* Result of the enclosing function. */
+ gfc_conv_expr_descriptor (se, expr, ss);
+ se->expr = build_fold_addr_expr (se->expr);
+
+ if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+ se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
+
+ return;
+ }
+ else
+ {
+ /* Every other type of array. */
+ se->want_pointer = 1;
+ gfc_conv_expr_descriptor (se, expr, ss);
+ }
+
/* Deallocate the allocatable components of structures that are
not variable. */
{
desc = se->expr;
/* Repack the array. */
- tmp = gfc_chainon_list (NULL_TREE, desc);
- ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+ ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
ptr = gfc_evaluate_now (ptr, &se->pre);
se->expr = ptr;
gfc_start_block (&block);
/* Copy the data back. */
- tmp = gfc_chainon_list (NULL_TREE, desc);
- tmp = gfc_chainon_list (tmp, ptr);
- tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
+ tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
/* Free the temporary. */
- tmp = convert (pvoid_type_node, ptr);
- tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ tmp = gfc_call_free (convert (pvoid_type_node, ptr));
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
gfc_start_block (&block);
- tmp = gfc_conv_descriptor_data_addr (descriptor);
- var = gfc_evaluate_now (tmp, &block);
+ var = gfc_conv_descriptor_data_get (descriptor);
+ STRIP_NOPS (var);
tmp = gfc_create_var (gfc_array_index_type, NULL);
ptr = build_fold_addr_expr (tmp);
/* 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_chainon_list (NULL_TREE, var);
- tmp = gfc_chainon_list (tmp, ptr);
- tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
+ tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
gfc_add_expr_to_block (&block, tmp);
+
+ /* Zero the data pointer. */
+ tmp = build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
+ gfc_add_expr_to_block (&block, tmp);
+
return gfc_finish_block (&block);
}
tree tmp;
tree size;
tree nelems;
- tree args;
tree null_cond;
tree null_data;
stmtblock_t block;
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
/* Allocate memory to the destination. */
- tmp = gfc_chainon_list (NULL_TREE, size);
- if (gfc_index_integer_kind == 4)
- tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
- else if (gfc_index_integer_kind == 8)
- tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
- else
- gcc_unreachable ();
- tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- tmp));
+ tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
+ size);
gfc_conv_descriptor_data_set (&block, dest, tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- tmp = gfc_conv_descriptor_data_get (dest);
- args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_conv_descriptor_data_get (src);
- args = gfc_chainon_list (args, tmp);
- args = gfc_chainon_list (args, size);
tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
+ gfc_conv_descriptor_data_get (src), size);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
null_cond = gfc_conv_descriptor_data_get (decl);
null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
- build_int_cst (TREE_TYPE (tmp), 0));
+ build_int_cst (TREE_TYPE (null_cond), 0));
}
else
{
if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
{
- rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
+ if (!sym->attr.save)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
else if (!GFC_DESCRIPTOR_TYPE_P (type))
{
/* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */
if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
- && !sym->attr.pointer)
+ && !sym->attr.pointer && !sym->attr.save)
{
int rank;
rank = sym->as ? sym->as->rank : 0;
forall (i=..., j=...)
x(i,j) = foo%a(j)%b(i)
end forall
- This adds a fair amout of complexity because you need to deal with more
+ This adds a fair amount of complexity because you need to deal with more
than one ref. Maybe handle in a similar manner to vector subscripts.
Maybe not worth the effort. */
OSDN Git Service
