+2012-08-23 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/54350
+ * trans-array.c (free_ss_info): Free data.array.subscript.
+ (gfc_free_ss): No longer free data.array.subscript.
+ (walk_coarray): New function, moved from trans-intrinsic.c
+ (gfc_conv_expr_descriptor): Walk array descriptor instead
+ of taking passed "ss".
+ (get_array_ctor_all_strlen, gfc_add_loop_ss_code,
+ gfc_conv_array_parameter): Update call and cleanup ss handling.
+ * trans-array.h (gfc_conv_expr_descriptor,
+ gfc_conv_array_parameter): Update prototype.
+ * trans-expr.c (gfc_conv_derived_to_class,
+ conv_isocbinding_procedure, gfc_conv_procedure_call,
+ gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign,
+ gfc_trans_pointer_assignment, gfc_trans_arrayfunc_assign): Update
+ call to gfc_conv_expr_descriptor and gfc_conv_array_parameter, and
+ clean up.
+ * trans-intrinsic.c (walk_coarray): Moved to trans-array.c
+ (trans_this_image, trans_image_index, gfc_conv_intrinsic_rank
+ gfc_conv_intrinsic_bound, gfc_conv_intrinsic_cobound,
+ gfc_conv_intrinsic_len, gfc_conv_intrinsic_size,
+ gfc_conv_intrinsic_sizeof, gfc_conv_intrinsic_storage_size,
+ gfc_conv_intrinsic_transfer, gfc_conv_allocated,
+ gfc_conv_associated, gfc_conv_intrinsic_loc,
+ conv_intrinsic_move_alloc): Update calls.
+ * trans-io.c (gfc_convert_array_to_string, set_internal_unit,
+ gfc_trans_transfer): Ditto.
+ * trans-stmt.c (gfc_conv_elemental_dependencies,
+ gfc_trans_sync, trans_associate_var,
+ gfc_trans_pointer_assign_need_temp): Ditto.
+
2012-08-23 Jakub Jelinek <jakub@redhat.com>
* trans-decl.c (trans_function_start, generate_coarray_init,
static void
free_ss_info (gfc_ss_info *ss_info)
{
+ int n;
+
ss_info->refcount--;
if (ss_info->refcount > 0)
return;
gcc_assert (ss_info->refcount == 0);
- free (ss_info);
-}
-
-
-/* Free a SS. */
-
-void
-gfc_free_ss (gfc_ss * ss)
-{
- gfc_ss_info *ss_info;
- int n;
-
- ss_info = ss->info;
switch (ss_info->type)
{
case GFC_SS_SECTION:
- for (n = 0; n < ss->dimen; n++)
- {
- if (ss_info->data.array.subscript[ss->dim[n]])
- gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
- }
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ if (ss_info->data.array.subscript[n])
+ gfc_free_ss_chain (ss_info->data.array.subscript[n]);
break;
default:
break;
}
- free_ss_info (ss_info);
+ free (ss_info);
+}
+
+
+/* Free a SS. */
+
+void
+gfc_free_ss (gfc_ss * ss)
+{
+ free_ss_info (ss->info);
free (ss);
}
get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
{
gfc_se se;
- gfc_ss *ss;
/* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len))
else
{
/* Otherwise, be brutal even if inefficient. */
- ss = gfc_walk_expr (e);
gfc_init_se (&se, NULL);
/* No function call, in case of side effects. */
se.no_function_call = 1;
- if (ss == gfc_ss_terminator)
+ if (e->rank == 0)
gfc_conv_expr (&se, e);
else
- gfc_conv_expr_descriptor (&se, e, ss);
+ gfc_conv_expr_descriptor (&se, e);
/* Fix the value. */
*len = gfc_evaluate_now (se.string_length, &se.pre);
case GFC_SS_VECTOR:
/* Get the vector's descriptor and store it in SS. */
gfc_init_se (&se, NULL);
- gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
+ gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
info->descriptor = se.expr;
return false;
}
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+ AR_FULL, suitable for the scalarizer. */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+ gfc_ss *ss;
+
+ gcc_assert (gfc_get_corank (e) > 0);
+
+ ss = gfc_walk_expr (e);
+
+ /* Fix scalar coarray. */
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_ref *ref;
+
+ ref = e->ref;
+ while (ref)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.codimen > 0)
+ break;
+
+ ref = ref->next;
+ }
+
+ gcc_assert (ref != NULL);
+ if (ref->u.ar.type == AR_ELEMENT)
+ ref->u.ar.type = AR_SECTION;
+ ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+ }
+
+ return ss;
+}
+
+
/* 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
function call. */
void
-gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
+gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
{
+ gfc_ss *ss;
gfc_ss_type ss_type;
gfc_ss_info *ss_info;
gfc_loopinfo loop;
bool subref_array_target = false;
gfc_expr *arg, *ss_expr;
+ if (se->want_coarray)
+ ss = walk_coarray (expr);
+ else
+ ss = gfc_walk_expr (expr);
+
gcc_assert (ss != NULL);
gcc_assert (ss != gfc_ss_terminator);
ss_type = ss_info->type;
ss_expr = ss_info->expr;
+ /* Special case: TRANSPOSE which needs no temporary. */
+ while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
+ && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
+ {
+ /* This is a call to transpose which has already been handled by the
+ scalarizer, so that we just need to get its argument's descriptor. */
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+ expr = expr->value.function.actual->expr;
+ }
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
}
- else if (info->ref->u.ar.type == AR_FULL)
+ else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
full = 1;
else if (se->direct_byref)
full = 0;
if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr);
+ gfc_free_ss_chain (ss);
return;
}
break;
case EXPR_FUNCTION:
-
- /* We don't need to copy data in some cases. */
- arg = gfc_get_noncopying_intrinsic_argument (expr);
- if (arg)
- {
- /* This is a call to transpose... */
- gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
- /* ... which has already been handled by the scalarizer, so
- that we just need to get its argument's descriptor. */
- gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
- return;
- }
-
/* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer
to create the descriptor. Elemental functions are handled as
gcc_assert (se->ss == ss);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
+ gfc_free_ss_chain (ss);
return;
}
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
tree *size)
{
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
{
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
se->expr = gfc_conv_array_data (se->expr);
return;
}
{
if (sym->attr.dummy || sym->attr.result)
{
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
tmp = se->expr;
}
if (size)
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
{
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
if (this_array_result)
{
/* Result of the enclosing function. */
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (size)
array_parameter_size (se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
{
/* Every other type of array. */
se->want_pointer = 1;
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (size)
array_parameter_size (build_fold_indirect_ref_loc (input_location,
se->expr),
void gfc_conv_tmp_ref (gfc_se *);
/* Evaluate an array expression. */
-void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
+void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, bool,
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool,
const gfc_symbol *, const char *, tree *);
/* Evaluate and transpose a matrix expression. */
void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
else
{
parmse->ss = ss;
- gfc_conv_expr_descriptor (parmse, e, ss);
+ gfc_conv_expr_descriptor (parmse, e);
if (e->rank != class_ts.u.derived->components->as->rank)
class_array_data_assign (&parmse->pre, ctree, parmse->expr, true);
loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &loopbody);
gfc_add_block_to_block (&body, &loop.pre);
- gfc_cleanup_loop (&loop);
tmp = gfc_finish_block (&body);
+ gfc_cleanup_loop (&loop);
}
else
{
gfc_actual_arglist * arg)
{
gfc_symbol *fsym;
- gfc_ss *argss;
-
+
if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
if (arg->expr->rank == 0)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- argss = gfc_walk_expr (arg->expr);
- gfc_conv_array_parameter (se, arg->expr, argss, f,
- NULL, NULL, NULL);
+ gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
}
/* TODO -- the following two lines shouldn't be necessary, but if
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
- gfc_ss *ss, *shape_ss;
+ gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
- ss = gfc_walk_expr (arg->next->expr);
- gcc_assert (ss != gfc_ss_terminator);
fptrse.descriptor_only = 1;
- gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss);
+ gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
- gfc_free_ss (ss);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
tree tmp;
tree fntype;
gfc_se parmse;
- gfc_ss *argss;
gfc_array_info *info;
int byref;
int parm_kind;
}
else
{
- /* A scalar or transformational function. */
- gfc_init_se (&parmse, NULL);
+ bool scalar;
+ gfc_ss *argss;
+
+ /* Check whether the expression is a scalar or not; we cannot use
+ e->rank as it can be nonzero for functions arguments. */
argss = gfc_walk_expr (e);
+ scalar = argss == gfc_ss_terminator;
+ if (!scalar)
+ gfc_free_ss_chain (argss);
- if (argss == gfc_ss_terminator)
+ /* A scalar or transformational function. */
+ gfc_init_se (&parmse, NULL);
+
+ if (scalar)
{
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.cray_pointee
{
/* Pass a class array. */
gfc_init_se (&parmse, se);
- gfc_conv_expr_descriptor (&parmse, e, argss);
+ gfc_conv_expr_descriptor (&parmse, e);
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else
- gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
- sym->name, NULL);
+ gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
gfc_expr * expr)
{
gfc_se se;
- gfc_ss *rss;
stmtblock_t block;
tree offset;
int n;
gfc_init_se (&se, NULL);
/* Get the descriptor for the expressions. */
- rss = gfc_walk_expr (expr);
se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr);
{
gfc_se se;
gfc_se lse;
- gfc_ss *rss;
stmtblock_t block;
tree tmp;
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else
{
- rss = gfc_walk_expr (expr);
se.direct_byref = 1;
se.expr = dest;
- gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&block, &se.post);
}
{
gfc_se lse;
gfc_se rse;
- gfc_ss *lss;
- gfc_ss *rss;
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
+ bool scalar;
+ gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
- lss = gfc_walk_expr (expr1);
- rss = gfc_walk_expr (expr2);
- if (lss == gfc_ss_terminator)
+ /* Check whether the expression is a scalar or not; we cannot use
+ expr1->rank as it can be nonzero for proc pointers. */
+ ss = gfc_walk_expr (expr1);
+ scalar = ss == gfc_ss_terminator;
+ if (!scalar)
+ gfc_free_ss_chain (ss);
+
+ if (scalar)
{
/* Scalar pointers. */
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
- gcc_assert (rss == gfc_ss_terminator);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
for (remap = expr1->ref; remap; remap = remap->next)
if (!remap->next && remap->type == REF_ARRAY
&& remap->u.ar.type == AR_SECTION)
- {
- remap->u.ar.type = AR_FULL;
- break;
- }
+ break;
rank_remap = (remap && remap->u.ar.end[0]);
- gfc_conv_expr_descriptor (&lse, expr1, lss);
+ if (remap)
+ lse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
gfc_init_se (&rse, NULL);
rse.direct_byref = 1;
rse.byref_noassign = 1;
- gfc_conv_expr_descriptor (&rse, expr2, rss);
+ gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length;
}
else if (expr2->expr_type == EXPR_VARIABLE)
{
/* Assign directly to the LHS's descriptor. */
lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2, rss);
+ gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length;
/* If this is a subreference array pointer assignment, use the rhs
lse.expr = tmp;
lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2, rss);
+ gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp);
}
gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_se se;
- gfc_ss *ss;
+ gfc_ss *ss = NULL;
gfc_component *comp = NULL;
gfc_loopinfo loop;
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));
- ss = gfc_walk_expr (expr1);
- gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
+ gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
if (expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived->attr.alloc_comp)
if (!expr2->value.function.isym)
{
+ ss = gfc_walk_expr (expr1);
+ gcc_assert (ss != gfc_ss_terminator);
+
realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
- gfc_cleanup_loop (&loop);
ss->is_alloc_lhs = 1;
}
else
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
- gfc_free_ss (se.ss);
return gfc_finish_block (&se.pre);
}
}
-/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
- AR_FULL, suitable for the scalarizer. */
-
-static gfc_ss *
-walk_coarray (gfc_expr *e)
-{
- gfc_ss *ss;
-
- gcc_assert (gfc_get_corank (e) > 0);
-
- ss = gfc_walk_expr (e);
-
- /* Fix scalar coarray. */
- if (ss == gfc_ss_terminator)
- {
- gfc_ref *ref;
-
- ref = e->ref;
- while (ref)
- {
- if (ref->type == REF_ARRAY
- && ref->u.ar.codimen > 0)
- break;
-
- ref = ref->next;
- }
-
- gcc_assert (ref != NULL);
- if (ref->u.ar.type == AR_ELEMENT)
- ref->u.ar.type = AR_SECTION;
- ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
- }
-
- return ss;
-}
-
-
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
lbound, ubound, extent, ml;
gfc_se argse;
- gfc_ss *ss;
int rank, corank;
/* The case -fcoarray=single is handled elsewhere. */
/* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL);
- ss = walk_coarray (expr->value.function.actual->expr);
- gcc_assert (ss != gfc_ss_terminator);
argse.want_coarray = 1;
- gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr;
tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
tmp, invalid_bound;
gfc_se argse, subse;
- gfc_ss *ss, *subss;
int rank, corank, codim;
type = gfc_get_int_type (gfc_default_integer_kind);
/* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL);
- ss = walk_coarray (expr->value.function.actual->expr);
- gcc_assert (ss != gfc_ss_terminator);
argse.want_coarray = 1;
- gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr;
/* Obtain a handle to the SUB argument. */
gfc_init_se (&subse, NULL);
- subss = gfc_walk_expr (expr->value.function.actual->next->expr);
- gcc_assert (subss != gfc_ss_terminator);
- gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
- subss);
+ gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
gfc_add_block_to_block (&se->pre, &subse.pre);
gfc_add_block_to_block (&se->post, &subse.post);
subdesc = build_fold_indirect_ref_loc (input_location,
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
- gfc_ss *ss;
- ss = gfc_walk_expr (expr->value.function.actual->expr);
- gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
argse.descriptor_only = 1;
- gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
- gfc_free_ss (ss);
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
tree ubound;
tree lbound;
gfc_se argse;
- gfc_ss *ss;
gfc_array_spec * as;
bool assumed_rank_lb_one;
/* TODO: don't re-evaluate the descriptor on each iteration. */
/* Get a descriptor for the first parameter. */
- ss = gfc_walk_expr (arg->expr);
- gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
- gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_conv_expr_descriptor (&argse, arg->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
gfc_actual_arglist *arg;
gfc_actual_arglist *arg2;
gfc_se argse;
- gfc_ss *ss;
tree bound, resbound, resbound2, desc, cond, tmp;
tree type;
int corank;
gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
corank = gfc_get_corank (arg->expr);
- ss = walk_coarray (arg->expr);
- gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.want_coarray = 1;
- gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_conv_expr_descriptor (&argse, arg->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr;
gfc_symbol *sym;
gfc_se argse;
gfc_expr *arg;
- gfc_ss *ss;
gcc_assert (!se->ss);
default:
/* Anybody stupid enough to do this deserves inefficient code. */
- ss = gfc_walk_expr (arg);
gfc_init_se (&argse, se);
- if (ss == gfc_ss_terminator)
+ if (arg->rank == 0)
gfc_conv_expr (&argse, arg);
else
- gfc_conv_expr_descriptor (&argse, arg, ss);
+ gfc_conv_expr_descriptor (&argse, arg);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
len = argse.string_length;
tree fncall0;
tree fncall1;
gfc_se argse;
- gfc_ss *ss;
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
- ss = gfc_walk_expr (actual->expr);
- gcc_assert (ss != gfc_ss_terminator);
argse.want_pointer = 1;
argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr, ss);
+ gfc_conv_expr_descriptor (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{
gfc_expr *arg;
- gfc_ss *ss;
gfc_se argse;
tree source_bytes;
tree type;
arg = expr->value.function.actual->expr;
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (arg);
- if (ss == gfc_ss_terminator)
+ if (arg->rank == 0)
{
if (arg->ts.type == BT_CLASS)
gfc_add_data_component (arg);
{
source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg, ss);
+ gfc_conv_expr_descriptor (&argse, arg);
type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Obtain the argument's word length. */
gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
gfc_expr *arg;
- gfc_ss *ss;
gfc_se argse,eight;
tree type, result_type, tmp;
gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (arg);
result_type = gfc_get_int_type (expr->ts.kind);
- if (ss == gfc_ss_terminator)
+ if (arg->rank == 0)
{
if (arg->ts.type == BT_CLASS)
{
else
{
argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg, ss);
+ gfc_conv_expr_descriptor (&argse, arg);
type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
tree stmt;
gfc_actual_arglist *arg;
gfc_se argse;
- gfc_ss *ss;
gfc_array_info *info;
stmtblock_t block;
int n;
arg->expr->value.function.name = "__transfer_in_transfer";
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (arg->expr);
source_bytes = gfc_create_var (gfc_array_index_type, NULL);
/* Obtain the pointer to source and the length of source in bytes. */
- if (ss == gfc_ss_terminator)
+ if (arg->expr->rank == 0)
{
gfc_conv_expr_reference (&argse, arg->expr);
source = argse.expr;
else
{
argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_conv_expr_descriptor (&argse, arg->expr);
source = gfc_conv_descriptor_data_get (argse.expr);
source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
arg = arg->next;
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (arg->expr);
scalar_mold = arg->expr->rank == 0;
- if (ss == gfc_ss_terminator)
+ if (arg->expr->rank == 0)
{
gfc_conv_expr_reference (&argse, arg->expr);
mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_conv_expr_descriptor (&argse, arg->expr);
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
{
gfc_actual_arglist *arg1;
gfc_se arg1se;
- gfc_ss *ss1;
tree tmp;
gfc_init_se (&arg1se, NULL);
gfc_add_data_component (arg1->expr);
}
- ss1 = gfc_walk_expr (arg1->expr);
-
- if (ss1 == gfc_ss_terminator)
+ if (arg1->expr->rank == 0)
{
/* Allocatable scalar. */
arg1se.want_pointer = 1;
{
/* Allocatable array. */
arg1se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr);
tmp = gfc_conv_descriptor_data_get (arg1se.expr);
}
tree tmp;
tree nonzero_charlen;
tree nonzero_arraylen;
- gfc_ss *ss1, *ss2;
+ gfc_ss *ss;
+ bool scalar;
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
if (arg1->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg1->expr);
arg2 = arg1->next;
- ss1 = gfc_walk_expr (arg1->expr);
+
+ /* Check whether the expression is a scalar or not; we cannot use
+ arg1->expr->rank as it can be nonzero for proc pointers. */
+ ss = gfc_walk_expr (arg1->expr);
+ scalar = ss == gfc_ss_terminator;
+ if (!scalar)
+ gfc_free_ss_chain (ss);
if (!arg2->expr)
{
/* No optional target. */
- if (ss1 == gfc_ss_terminator)
+ if (scalar)
{
/* A pointer to a scalar. */
arg1se.want_pointer = 1;
else
{
/* A pointer to an array. */
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr);
tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
}
gfc_add_block_to_block (&se->pre, &arg1se.pre);
/* An optional target. */
if (arg2->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg2->expr);
- ss2 = gfc_walk_expr (arg2->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
boolean_type_node,
arg1->expr->ts.u.cl->backend_decl,
integer_zero_node);
-
- if (ss1 == gfc_ss_terminator)
+ if (scalar)
{
/* A pointer to a scalar. */
- gcc_assert (ss2 == gfc_ss_terminator);
arg1se.want_pointer = 1;
gfc_conv_expr (&arg1se, arg1->expr);
if (arg1->expr->symtree->n.sym->attr.proc_pointer
build_int_cst (TREE_TYPE (tmp), 0));
/* A pointer to an array, call library function _gfor_associated. */
- gcc_assert (ss2 != gfc_ss_terminator);
arg1se.want_pointer = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr);
arg2se.want_pointer = 1;
- gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
+ gfc_conv_expr_descriptor (&arg2se, arg2->expr);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
se->expr = build_call_expr_loc (input_location,
{
tree temp_var;
gfc_expr *arg_expr;
- gfc_ss *ss;
gcc_assert (!se->ss);
arg_expr = expr->value.function.actual->expr;
- ss = gfc_walk_expr (arg_expr);
- if (ss == gfc_ss_terminator)
+ if (arg_expr->rank == 0)
gfc_conv_expr_reference (se, arg_expr);
else
- gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
+ gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this,
gfc_expr *from_expr, *to_expr;
gfc_expr *to_expr2, *from_expr2 = NULL;
gfc_se from_se, to_se;
- gfc_ss *from_ss, *to_ss;
tree tmp;
bool coarray;
}
}
+
/* Deallocate "to". */
- if (from_expr->rank != 0)
- {
- to_ss = gfc_walk_expr (to_expr);
- from_ss = gfc_walk_expr (from_expr);
- }
- else
+ if (from_expr->rank == 0)
{
- to_ss = walk_coarray (to_expr);
- from_ss = walk_coarray (from_expr);
+ to_se.want_coarray = 1;
+ from_se.want_coarray = 1;
}
- gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
- gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
+ gfc_conv_expr_descriptor (&to_se, to_expr);
+ gfc_conv_expr_descriptor (&from_se, from_expr);
/* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
is an image control "statement", cf. IR F08/0040 in 12-006A. */
return;
}
- gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
+ gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
se->string_length = fold_convert (gfc_charlen_type_node, size);
}
/* Character array. */
else if (e->rank > 0)
{
- se.ss = gfc_walk_expr (e);
-
if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
else
{
/* Return the data pointer and rank from the descriptor. */
- gfc_conv_expr_descriptor (&se, e, se.ss);
+ gfc_conv_expr_descriptor (&se, e);
tmp = gfc_conv_descriptor_data_get (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
}
gfc_init_block (&body);
expr = code->expr1;
- ss = gfc_walk_expr (expr);
-
ref = NULL;
gfc_init_se (&se, NULL);
- if (ss == gfc_ss_terminator)
+ if (expr->rank == 0)
{
/* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr);
else
{
/* Get the descriptor. */
- gfc_conv_expr_descriptor (&se, expr, ss);
+ gfc_conv_expr_descriptor (&se, expr);
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
}
transfer_array_desc (&se, &expr->ts, tmp);
goto finish_block_label;
}
-
+
/* Initialize the scalarizer. */
+ ss = gfc_walk_expr (expr);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
/* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1;
- gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
+ gfc_conv_expr_descriptor (&parmse, e);
gfc_add_block_to_block (&se->pre, &parmse.pre);
/* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
"implemented for image-set at %L",
gfc_c_int_kind, &code->expr1->where);
- gfc_conv_array_parameter (&se, code->expr1,
- gfc_walk_expr (code->expr1), true, NULL,
- NULL, &len);
+ gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
images = se.expr;
tmp = gfc_typenode_for_spec (&code->expr1->ts);
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
- gfc_ss *ss;
tree desc;
desc = sym->backend_decl;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
- ss = gfc_walk_expr (e);
if (sym->assoc->variable)
{
se.direct_byref = 1;
se.expr = desc;
}
- gfc_conv_expr_descriptor (&se, e, ss);
+ gfc_conv_expr_descriptor (&se, e);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
/* For a class array we need a descriptor for the selector. */
- gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e));
+ gfc_conv_expr_descriptor (&se, e);
/* Obtain a temporary class container for the result. */
gfc_conv_class_to_class (&se, e, sym->ts, false);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.direct_byref = 1;
- rss = gfc_walk_expr (expr2);
- gfc_conv_expr_descriptor (&lse, expr2, rss);
+ gfc_conv_expr_descriptor (&lse, expr2);
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_block_to_block (&body, &lse.post);
gfc_add_modify (block, count, gfc_index_zero_node);
parm = gfc_build_array_ref (tmp1, count, NULL);
- lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL);
- gfc_conv_expr_descriptor (&lse, expr1, lss);
+ gfc_conv_expr_descriptor (&lse, expr1);
gfc_add_modify (&lse.pre, lse.expr, parm);
gfc_start_block (&body);
gfc_add_block_to_block (&body, &lse.pre);
OSDN Git Service
