OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/54350 (FAIL: gfortran.dg/realloc_on_assign_*.f90 -O (internal compiler error) at r190586) 

2012-08-24  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.

From-SVN: r190641
This commit is contained in:
Tobias Burnus 2012-08-24 09:43:23 +02:00 committed by Tobias Burnus
parent 3c5e0cc46e
commit 2960a36853
7 changed files with 214 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/fortran/ChangeLog
View File

@ -1,3 +1,35 @@
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> 2012-08-23 Jakub Jelinek <jakub@redhat.com>
* trans-decl.c (trans_function_start, generate_coarray_init, * trans-decl.c (trans_function_start, generate_coarray_init,

129
gcc/fortran/trans-array.c
View File

@ -510,11 +510,26 @@ gfc_free_ss_chain (gfc_ss * ss)
static void static void
free_ss_info (gfc_ss_info *ss_info) free_ss_info (gfc_ss_info *ss_info)
{ {
int n;
ss_info->refcount--; ss_info->refcount--;
if (ss_info->refcount > 0) if (ss_info->refcount > 0)
return; return;
gcc_assert (ss_info->refcount == 0); gcc_assert (ss_info->refcount == 0);
switch (ss_info->type)
{
case GFC_SS_SECTION:
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); free (ss_info);
} }
@ -524,26 +539,7 @@ free_ss_info (gfc_ss_info *ss_info)
void void
gfc_free_ss (gfc_ss * ss) gfc_free_ss (gfc_ss * ss)
{ {
gfc_ss_info *ss_info; free_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]]);
}
break;
default:
break;
}
free_ss_info (ss_info);
free (ss); free (ss);
} }
@ -1805,7 +1801,6 @@ static void
get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
{ {
gfc_se se; gfc_se se;
gfc_ss *ss;
/* Don't bother if we already know the length is a constant. */ /* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len)) if (*len && INTEGER_CST_P (*len))
@ -1821,15 +1816,14 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
else else
{ {
/* Otherwise, be brutal even if inefficient. */ /* Otherwise, be brutal even if inefficient. */
ss = gfc_walk_expr (e);
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
/* No function call, in case of side effects. */ /* No function call, in case of side effects. */
se.no_function_call = 1; se.no_function_call = 1;
if (ss == gfc_ss_terminator) if (e->rank == 0)
gfc_conv_expr (&se, e); gfc_conv_expr (&se, e);
else else
gfc_conv_expr_descriptor (&se, e, ss); gfc_conv_expr_descriptor (&se, e);
/* Fix the value. */ /* Fix the value. */
*len = gfc_evaluate_now (se.string_length, &se.pre); *len = gfc_evaluate_now (se.string_length, &se.pre);
@ -2527,7 +2521,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
case GFC_SS_VECTOR: case GFC_SS_VECTOR:
/* Get the vector's descriptor and store it in SS. */ /* Get the vector's descriptor and store it in SS. */
gfc_init_se (&se, NULL); 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->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post); gfc_add_block_to_block (&outer_loop->post, &se.post);
info->descriptor = se.expr; info->descriptor = se.expr;
@ -6328,6 +6322,44 @@ transposed_dims (gfc_ss *ss)
return false; 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 /* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections passed. For whole arrays the descriptor is passed. For array sections
@ -6358,8 +6390,9 @@ transposed_dims (gfc_ss *ss)
function call. */ function call. */
void 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_type ss_type;
gfc_ss_info *ss_info; gfc_ss_info *ss_info;
gfc_loopinfo loop; gfc_loopinfo loop;
@ -6375,6 +6408,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
bool subref_array_target = false; bool subref_array_target = false;
gfc_expr *arg, *ss_expr; 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 != NULL);
gcc_assert (ss != gfc_ss_terminator); gcc_assert (ss != gfc_ss_terminator);
@ -6382,6 +6420,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
ss_type = ss_info->type; ss_type = ss_info->type;
ss_expr = ss_info->expr; 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. */ /* Special case things we know we can pass easily. */
switch (expr->expr_type) switch (expr->expr_type)
{ {
@ -6411,7 +6459,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* Create a new descriptor if the array doesn't have one. */ /* Create a new descriptor if the array doesn't have one. */
full = 0; 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; full = 1;
else if (se->direct_byref) else if (se->direct_byref)
full = 0; full = 0;
@ -6443,24 +6491,12 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
if (expr->ts.type == BT_CHARACTER) if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr); se->string_length = gfc_get_expr_charlen (expr);
gfc_free_ss_chain (ss);
return; return;
} }
break; break;
case EXPR_FUNCTION: 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 /* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer array descriptor. We still need to go through the scalarizer
to create the descriptor. Elemental functions are handled as to create the descriptor. Elemental functions are handled as
@ -6477,6 +6513,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
gcc_assert (se->ss == ss); gcc_assert (se->ss == ss);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr); gfc_conv_expr (se, expr);
gfc_free_ss_chain (ss);
return; return;
} }
@ -6896,7 +6933,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size)
/* TODO: Optimize passing g77 arrays. */ /* TODO: Optimize passing g77 arrays. */
void 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, const gfc_symbol *fsym, const char *proc_name,
tree *size) tree *size)
{ {
@ -6967,7 +7004,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 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); se->expr = gfc_conv_array_data (se->expr);
return; return;
} }
@ -6993,7 +7030,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
{ {
if (sym->attr.dummy || sym->attr.result) if (sym->attr.dummy || sym->attr.result)
{ {
gfc_conv_expr_descriptor (se, expr, ss); gfc_conv_expr_descriptor (se, expr);
tmp = se->expr; tmp = se->expr;
} }
if (size) if (size)
@ -7037,7 +7074,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) 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) if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->ts.u.cl->backend_decl; se->string_length = expr->ts.u.cl->backend_decl;
if (size) if (size)
@ -7049,7 +7086,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
if (this_array_result) if (this_array_result)
{ {
/* Result of the enclosing function. */ /* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr, ss); gfc_conv_expr_descriptor (se, expr);
if (size) if (size)
array_parameter_size (se->expr, expr, size); array_parameter_size (se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
@ -7065,7 +7102,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
{ {
/* Every other type of array. */ /* Every other type of array. */
se->want_pointer = 1; se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss); gfc_conv_expr_descriptor (se, expr);
if (size) if (size)
array_parameter_size (build_fold_indirect_ref_loc (input_location, array_parameter_size (build_fold_indirect_ref_loc (input_location,
se->expr), se->expr),

4
gcc/fortran/trans-array.h
View File

@ -131,9 +131,9 @@ void gfc_conv_tmp_array_ref (gfc_se * se);
void gfc_conv_tmp_ref (gfc_se *); void gfc_conv_tmp_ref (gfc_se *);
/* Evaluate an array expression. */ /* 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. */ /* 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 *); const gfc_symbol *, const char *, tree *);
/* Evaluate and transpose a matrix expression. */ /* Evaluate and transpose a matrix expression. */
void gfc_conv_array_transpose (gfc_se *, gfc_expr *); void gfc_conv_array_transpose (gfc_se *, gfc_expr *);

83
gcc/fortran/trans-expr.c
View File

@ -304,7 +304,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
else else
{ {
parmse->ss = ss; 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) if (e->rank != class_ts.u.derived->components->as->rank)
class_array_data_assign (&parmse->pre, ctree, parmse->expr, true); class_array_data_assign (&parmse->pre, ctree, parmse->expr, true);
@ -533,8 +533,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
loop.to[0] = nelems; loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &loopbody); gfc_trans_scalarizing_loops (&loop, &loopbody);
gfc_add_block_to_block (&body, &loop.pre); gfc_add_block_to_block (&body, &loop.pre);
gfc_cleanup_loop (&loop);
tmp = gfc_finish_block (&body); tmp = gfc_finish_block (&body);
gfc_cleanup_loop (&loop);
} }
else else
{ {
@ -3385,7 +3385,6 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg) gfc_actual_arglist * arg)
{ {
gfc_symbol *fsym; gfc_symbol *fsym;
gfc_ss *argss;
if (sym->intmod_sym_id == ISOCBINDING_LOC) if (sym->intmod_sym_id == ISOCBINDING_LOC)
{ {
@ -3404,9 +3403,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
&& fsym->as->type != AS_ASSUMED_SHAPE; && fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit; f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr); gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
gfc_conv_array_parameter (se, arg->expr, argss, f,
NULL, NULL, NULL);
} }
/* TODO -- the following two lines shouldn't be necessary, but if /* TODO -- the following two lines shouldn't be necessary, but if
@ -3434,7 +3431,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_se cptrse; gfc_se cptrse;
gfc_se fptrse; gfc_se fptrse;
gfc_se shapese; gfc_se shapese;
gfc_ss *ss, *shape_ss; gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset; tree desc, dim, tmp, stride, offset;
stmtblock_t body, block; stmtblock_t body, block;
gfc_loopinfo loop; gfc_loopinfo loop;
@ -3469,10 +3466,8 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_start_block (&block); gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */ /* Get the descriptor of the Fortran pointer. */
ss = gfc_walk_expr (arg->next->expr);
gcc_assert (ss != gfc_ss_terminator);
fptrse.descriptor_only = 1; 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); gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr; desc = fptrse.expr;
@ -3534,7 +3529,6 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&block, &loop.post); gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post); gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop); gfc_cleanup_loop (&loop);
gfc_free_ss (ss);
gfc_add_modify (&block, offset, gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR, fold_build1_loc (input_location, NEGATE_EXPR,
@ -3615,7 +3609,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tree tmp; tree tmp;
tree fntype; tree fntype;
gfc_se parmse; gfc_se parmse;
gfc_ss *argss;
gfc_array_info *info; gfc_array_info *info;
int byref; int byref;
int parm_kind; int parm_kind;
@ -3818,11 +3811,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
} }
else else
{ {
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);
/* A scalar or transformational function. */ /* A scalar or transformational function. */
gfc_init_se (&parmse, NULL); gfc_init_se (&parmse, NULL);
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator) if (scalar)
{ {
if (e->expr_type == EXPR_VARIABLE if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.cray_pointee && e->symtree->n.sym->attr.cray_pointee
@ -3977,7 +3979,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{ {
/* Pass a class array. */ /* Pass a class array. */
gfc_init_se (&parmse, se); 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 /* The conversion does not repackage the reference to a class
array - _data descriptor. */ array - _data descriptor. */
gfc_conv_class_to_class (&parmse, e, fsym->ts, false); gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
@ -4060,8 +4062,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fsym ? fsym->attr.intent : INTENT_INOUT, fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer); fsym && fsym->attr.pointer);
else else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym, gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */ allocated on entry, it must be deallocated. */
@ -5355,7 +5356,6 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr) gfc_expr * expr)
{ {
gfc_se se; gfc_se se;
gfc_ss *rss;
stmtblock_t block; stmtblock_t block;
tree offset; tree offset;
int n; int n;
@ -5368,9 +5368,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
/* Get the descriptor for the expressions. */ /* Get the descriptor for the expressions. */
rss = gfc_walk_expr (expr);
se.want_pointer = 0; 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_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr); gfc_add_modify (&block, dest, se.expr);
@ -5501,7 +5500,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{ {
gfc_se se; gfc_se se;
gfc_se lse; gfc_se lse;
gfc_ss *rss;
stmtblock_t block; stmtblock_t block;
tree tmp; tree tmp;
@ -5518,10 +5516,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else else
{ {
rss = gfc_walk_expr (expr);
se.direct_byref = 1; se.direct_byref = 1;
se.expr = dest; 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.pre);
gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &se.post);
} }
@ -5966,25 +5963,29 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{ {
gfc_se lse; gfc_se lse;
gfc_se rse; gfc_se rse;
gfc_ss *lss;
gfc_ss *rss;
stmtblock_t block; stmtblock_t block;
tree desc; tree desc;
tree tmp; tree tmp;
tree decl; tree decl;
bool scalar;
gfc_ss *ss;
gfc_start_block (&block); gfc_start_block (&block);
gfc_init_se (&lse, NULL); gfc_init_se (&lse, NULL);
lss = gfc_walk_expr (expr1); /* Check whether the expression is a scalar or not; we cannot use
rss = gfc_walk_expr (expr2); expr1->rank as it can be nonzero for proc pointers. */
if (lss == gfc_ss_terminator) ss = gfc_walk_expr (expr1);
scalar = ss == gfc_ss_terminator;
if (!scalar)
gfc_free_ss_chain (ss);
if (scalar)
{ {
/* Scalar pointers. */ /* Scalar pointers. */
lse.want_pointer = 1; lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1); gfc_conv_expr (&lse, expr1);
gcc_assert (rss == gfc_ss_terminator);
gfc_init_se (&rse, NULL); gfc_init_se (&rse, NULL);
rse.want_pointer = 1; rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2); gfc_conv_expr (&rse, expr2);
@ -6048,13 +6049,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
for (remap = expr1->ref; remap; remap = remap->next) for (remap = expr1->ref; remap; remap = remap->next)
if (!remap->next && remap->type == REF_ARRAY if (!remap->next && remap->type == REF_ARRAY
&& remap->u.ar.type == AR_SECTION) && remap->u.ar.type == AR_SECTION)
{
remap->u.ar.type = AR_FULL;
break; break;
}
rank_remap = (remap && remap->u.ar.end[0]); 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; strlen_lhs = lse.string_length;
desc = lse.expr; desc = lse.expr;
@ -6070,14 +6070,14 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL); gfc_init_se (&rse, NULL);
rse.direct_byref = 1; rse.direct_byref = 1;
rse.byref_noassign = 1; rse.byref_noassign = 1;
gfc_conv_expr_descriptor (&rse, expr2, rss); gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length; strlen_rhs = rse.string_length;
} }
else if (expr2->expr_type == EXPR_VARIABLE) else if (expr2->expr_type == EXPR_VARIABLE)
{ {
/* Assign directly to the LHS's descriptor. */ /* Assign directly to the LHS's descriptor. */
lse.direct_byref = 1; lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss); gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length; strlen_rhs = lse.string_length;
/* If this is a subreference array pointer assignment, use the rhs /* If this is a subreference array pointer assignment, use the rhs
@ -6103,7 +6103,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
lse.expr = tmp; lse.expr = tmp;
lse.direct_byref = 1; lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss); gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length; strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp); gfc_add_modify (&lse.pre, desc, tmp);
} }
@ -6715,7 +6715,7 @@ static tree
gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
{ {
gfc_se se; gfc_se se;
gfc_ss *ss; gfc_ss *ss = NULL;
gfc_component *comp = NULL; gfc_component *comp = NULL;
gfc_loopinfo loop; gfc_loopinfo loop;
@ -6730,13 +6730,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym) || (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension)); && expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gfc_start_block (&se.pre); gfc_start_block (&se.pre);
se.want_pointer = 1; 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 if (expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived->attr.alloc_comp) && expr1->ts.u.derived->attr.alloc_comp)
@ -6770,8 +6768,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
if (!expr2->value.function.isym) 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); realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
gfc_cleanup_loop (&loop);
ss->is_alloc_lhs = 1; ss->is_alloc_lhs = 1;
} }
else else
@ -6780,7 +6780,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_conv_function_expr (&se, expr2); gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post); gfc_add_block_to_block (&se.pre, &se.post);
gfc_free_ss (se.ss);
return gfc_finish_block (&se.pre); return gfc_finish_block (&se.pre);
} }

157
gcc/fortran/trans-intrinsic.c
View File

@ -923,43 +923,6 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
} }
/* 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 static void
trans_this_image (gfc_se * se, gfc_expr *expr) trans_this_image (gfc_se * se, gfc_expr *expr)
{ {
@ -967,7 +930,6 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
lbound, ubound, extent, ml; lbound, ubound, extent, ml;
gfc_se argse; gfc_se argse;
gfc_ss *ss;
int rank, corank; int rank, corank;
/* The case -fcoarray=single is handled elsewhere. */ /* The case -fcoarray=single is handled elsewhere. */
@ -991,10 +953,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
/* Obtain the descriptor of the COARRAY. */ /* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
ss = walk_coarray (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
argse.want_coarray = 1; 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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr; desc = argse.expr;
@ -1186,7 +1146,6 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
tmp, invalid_bound; tmp, invalid_bound;
gfc_se argse, subse; gfc_se argse, subse;
gfc_ss *ss, *subss;
int rank, corank, codim; int rank, corank, codim;
type = gfc_get_int_type (gfc_default_integer_kind); type = gfc_get_int_type (gfc_default_integer_kind);
@ -1195,20 +1154,15 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
/* Obtain the descriptor of the COARRAY. */ /* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
ss = walk_coarray (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
argse.want_coarray = 1; 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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr; desc = argse.expr;
/* Obtain a handle to the SUB argument. */ /* Obtain a handle to the SUB argument. */
gfc_init_se (&subse, NULL); gfc_init_se (&subse, NULL);
subss = gfc_walk_expr (expr->value.function.actual->next->expr); gfc_conv_expr_descriptor (&subse, 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_add_block_to_block (&se->pre, &subse.pre); gfc_add_block_to_block (&se->pre, &subse.pre);
gfc_add_block_to_block (&se->post, &subse.post); gfc_add_block_to_block (&se->post, &subse.post);
subdesc = build_fold_indirect_ref_loc (input_location, subdesc = build_fold_indirect_ref_loc (input_location,
@ -1319,16 +1273,12 @@ static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{ {
gfc_se argse; 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); gfc_init_se (&argse, NULL);
argse.data_not_needed = 1; argse.data_not_needed = 1;
argse.descriptor_only = 1; argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss); gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
gfc_free_ss (ss);
gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
@ -1352,7 +1302,6 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
tree ubound; tree ubound;
tree lbound; tree lbound;
gfc_se argse; gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as; gfc_array_spec * as;
bool assumed_rank_lb_one; bool assumed_rank_lb_one;
@ -1387,10 +1336,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
/* TODO: don't re-evaluate the descriptor on each iteration. */ /* TODO: don't re-evaluate the descriptor on each iteration. */
/* Get a descriptor for the first parameter. */ /* 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_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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
@ -1556,7 +1503,6 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
gfc_actual_arglist *arg; gfc_actual_arglist *arg;
gfc_actual_arglist *arg2; gfc_actual_arglist *arg2;
gfc_se argse; gfc_se argse;
gfc_ss *ss;
tree bound, resbound, resbound2, desc, cond, tmp; tree bound, resbound, resbound2, desc, cond, tmp;
tree type; tree type;
int corank; int corank;
@ -1571,12 +1517,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
corank = gfc_get_corank (arg->expr); corank = gfc_get_corank (arg->expr);
ss = walk_coarray (arg->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
argse.want_coarray = 1; 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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
desc = argse.expr; desc = argse.expr;
@ -4595,7 +4539,6 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
gfc_symbol *sym; gfc_symbol *sym;
gfc_se argse; gfc_se argse;
gfc_expr *arg; gfc_expr *arg;
gfc_ss *ss;
gcc_assert (!se->ss); gcc_assert (!se->ss);
@ -4637,12 +4580,11 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
default: default:
/* Anybody stupid enough to do this deserves inefficient code. */ /* Anybody stupid enough to do this deserves inefficient code. */
ss = gfc_walk_expr (arg);
gfc_init_se (&argse, se); gfc_init_se (&argse, se);
if (ss == gfc_ss_terminator) if (arg->rank == 0)
gfc_conv_expr (&argse, arg); gfc_conv_expr (&argse, arg);
else 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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
len = argse.string_length; len = argse.string_length;
@ -5099,7 +5041,6 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
tree fncall0; tree fncall0;
tree fncall1; tree fncall1;
gfc_se argse; gfc_se argse;
gfc_ss *ss;
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
actual = expr->value.function.actual; actual = expr->value.function.actual;
@ -5107,11 +5048,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
if (actual->expr->ts.type == BT_CLASS) if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr); gfc_add_class_array_ref (actual->expr);
ss = gfc_walk_expr (actual->expr);
gcc_assert (ss != gfc_ss_terminator);
argse.want_pointer = 1; argse.want_pointer = 1;
argse.data_not_needed = 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->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre); arg1 = gfc_evaluate_now (argse.expr, &se->pre);
@ -5214,7 +5153,6 @@ static void
gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{ {
gfc_expr *arg; gfc_expr *arg;
gfc_ss *ss;
gfc_se argse; gfc_se argse;
tree source_bytes; tree source_bytes;
tree type; tree type;
@ -5226,9 +5164,8 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
arg = expr->value.function.actual->expr; arg = expr->value.function.actual->expr;
gfc_init_se (&argse, NULL); 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) if (arg->ts.type == BT_CLASS)
gfc_add_data_component (arg); gfc_add_data_component (arg);
@ -5249,7 +5186,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{ {
source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
argse.want_pointer = 0; 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)); type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Obtain the argument's word length. */ /* Obtain the argument's word length. */
@ -5286,7 +5223,6 @@ static void
gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{ {
gfc_expr *arg; gfc_expr *arg;
gfc_ss *ss;
gfc_se argse,eight; gfc_se argse,eight;
tree type, result_type, tmp; tree type, result_type, tmp;
@ -5295,10 +5231,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8)); gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg);
result_type = gfc_get_int_type (expr->ts.kind); result_type = gfc_get_int_type (expr->ts.kind);
if (ss == gfc_ss_terminator) if (arg->rank == 0)
{ {
if (arg->ts.type == BT_CLASS) if (arg->ts.type == BT_CLASS)
{ {
@ -5316,7 +5251,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
else else
{ {
argse.want_pointer = 0; 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)); type = gfc_get_element_type (TREE_TYPE (argse.expr));
} }
@ -5410,7 +5345,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
tree stmt; tree stmt;
gfc_actual_arglist *arg; gfc_actual_arglist *arg;
gfc_se argse; gfc_se argse;
gfc_ss *ss;
gfc_array_info *info; gfc_array_info *info;
stmtblock_t block; stmtblock_t block;
int n; int n;
@ -5436,12 +5370,11 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
arg->expr->value.function.name = "__transfer_in_transfer"; arg->expr->value.function.name = "__transfer_in_transfer";
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
source_bytes = gfc_create_var (gfc_array_index_type, NULL); source_bytes = gfc_create_var (gfc_array_index_type, NULL);
/* Obtain the pointer to source and the length of source in bytes. */ /* 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); gfc_conv_expr_reference (&argse, arg->expr);
source = argse.expr; source = argse.expr;
@ -5460,7 +5393,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
else else
{ {
argse.want_pointer = 0; 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 = gfc_conv_descriptor_data_get (argse.expr);
source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
@ -5534,11 +5467,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
arg = arg->next; arg = arg->next;
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
scalar_mold = arg->expr->rank == 0; scalar_mold = arg->expr->rank == 0;
if (ss == gfc_ss_terminator) if (arg->expr->rank == 0)
{ {
gfc_conv_expr_reference (&argse, arg->expr); gfc_conv_expr_reference (&argse, arg->expr);
mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@ -5548,7 +5480,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{ {
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
argse.want_pointer = 0; 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)); mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
} }
@ -5741,7 +5673,6 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
{ {
gfc_actual_arglist *arg1; gfc_actual_arglist *arg1;
gfc_se arg1se; gfc_se arg1se;
gfc_ss *ss1;
tree tmp; tree tmp;
gfc_init_se (&arg1se, NULL); gfc_init_se (&arg1se, NULL);
@ -5758,9 +5689,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
gfc_add_data_component (arg1->expr); gfc_add_data_component (arg1->expr);
} }
ss1 = gfc_walk_expr (arg1->expr); if (arg1->expr->rank == 0)
if (ss1 == gfc_ss_terminator)
{ {
/* Allocatable scalar. */ /* Allocatable scalar. */
arg1se.want_pointer = 1; arg1se.want_pointer = 1;
@ -5771,7 +5700,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
{ {
/* Allocatable array. */ /* Allocatable array. */
arg1se.descriptor_only = 1; 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); tmp = gfc_conv_descriptor_data_get (arg1se.expr);
} }
@ -5798,7 +5727,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
tree tmp; tree tmp;
tree nonzero_charlen; tree nonzero_charlen;
tree nonzero_arraylen; tree nonzero_arraylen;
gfc_ss *ss1, *ss2; gfc_ss *ss;
bool scalar;
gfc_init_se (&arg1se, NULL); gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL); gfc_init_se (&arg2se, NULL);
@ -5806,12 +5736,18 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
if (arg1->expr->ts.type == BT_CLASS) if (arg1->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg1->expr); gfc_add_data_component (arg1->expr);
arg2 = arg1->next; 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) if (!arg2->expr)
{ {
/* No optional target. */ /* No optional target. */
if (ss1 == gfc_ss_terminator) if (scalar)
{ {
/* A pointer to a scalar. */ /* A pointer to a scalar. */
arg1se.want_pointer = 1; arg1se.want_pointer = 1;
@ -5825,7 +5761,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
else else
{ {
/* A pointer to an array. */ /* 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); tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
} }
gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->pre, &arg1se.pre);
@ -5839,7 +5775,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
/* An optional target. */ /* An optional target. */
if (arg2->expr->ts.type == BT_CLASS) if (arg2->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg2->expr); gfc_add_data_component (arg2->expr);
ss2 = gfc_walk_expr (arg2->expr);
nonzero_charlen = NULL_TREE; nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER) if (arg1->expr->ts.type == BT_CHARACTER)
@ -5847,11 +5782,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
boolean_type_node, boolean_type_node,
arg1->expr->ts.u.cl->backend_decl, arg1->expr->ts.u.cl->backend_decl,
integer_zero_node); integer_zero_node);
if (scalar)
if (ss1 == gfc_ss_terminator)
{ {
/* A pointer to a scalar. */ /* A pointer to a scalar. */
gcc_assert (ss2 == gfc_ss_terminator);
arg1se.want_pointer = 1; arg1se.want_pointer = 1;
gfc_conv_expr (&arg1se, arg1->expr); gfc_conv_expr (&arg1se, arg1->expr);
if (arg1->expr->symtree->n.sym->attr.proc_pointer if (arg1->expr->symtree->n.sym->attr.proc_pointer
@ -5894,12 +5827,11 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
build_int_cst (TREE_TYPE (tmp), 0)); build_int_cst (TREE_TYPE (tmp), 0));
/* A pointer to an array, call library function _gfor_associated. */ /* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
arg1se.want_pointer = 1; arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); gfc_conv_expr_descriptor (&arg1se, arg1->expr);
arg2se.want_pointer = 1; 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->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post); gfc_add_block_to_block (&se->post, &arg2se.post);
se->expr = build_call_expr_loc (input_location, se->expr = build_call_expr_loc (input_location,
@ -6254,16 +6186,14 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
{ {
tree temp_var; tree temp_var;
gfc_expr *arg_expr; gfc_expr *arg_expr;
gfc_ss *ss;
gcc_assert (!se->ss); gcc_assert (!se->ss);
arg_expr = expr->value.function.actual->expr; arg_expr = expr->value.function.actual->expr;
ss = gfc_walk_expr (arg_expr); if (arg_expr->rank == 0)
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr); gfc_conv_expr_reference (se, arg_expr);
else 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); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this, /* Create a temporary variable for loc return value. Without this,
@ -7302,7 +7232,6 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_expr *from_expr, *to_expr; gfc_expr *from_expr, *to_expr;
gfc_expr *to_expr2, *from_expr2 = NULL; gfc_expr *to_expr2, *from_expr2 = NULL;
gfc_se from_se, to_se; gfc_se from_se, to_se;
gfc_ss *from_ss, *to_ss;
tree tmp; tree tmp;
bool coarray; bool coarray;
@ -7428,19 +7357,15 @@ conv_intrinsic_move_alloc (gfc_code *code)
} }
} }
/* Deallocate "to". */ /* Deallocate "to". */
if (from_expr->rank != 0) if (from_expr->rank == 0)
{ {
to_ss = gfc_walk_expr (to_expr); to_se.want_coarray = 1;
from_ss = gfc_walk_expr (from_expr); from_se.want_coarray = 1;
} }
else gfc_conv_expr_descriptor (&to_se, to_expr);
{ gfc_conv_expr_descriptor (&from_se, from_expr);
to_ss = walk_coarray (to_expr);
from_ss = walk_coarray (from_expr);
}
gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
/* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC /* 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. */ is an image control "statement", cf. IR F08/0040 in 12-006A. */

13
gcc/fortran/trans-io.c
View File

@ -664,7 +664,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
return; 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); se->string_length = fold_convert (gfc_charlen_type_node, size);
} }
@ -780,8 +780,6 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
/* Character array. */ /* Character array. */
else if (e->rank > 0) else if (e->rank > 0)
{ {
se.ss = gfc_walk_expr (e);
if (is_subref_array (e)) if (is_subref_array (e))
{ {
/* Use a temporary for components of arrays of derived types /* Use a temporary for components of arrays of derived types
@ -796,7 +794,7 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
else else
{ {
/* Return the data pointer and rank from the descriptor. */ /* 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); tmp = gfc_conv_descriptor_data_get (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
} }
@ -2236,12 +2234,10 @@ gfc_trans_transfer (gfc_code * code)
gfc_init_block (&body); gfc_init_block (&body);
expr = code->expr1; expr = code->expr1;
ss = gfc_walk_expr (expr);
ref = NULL; ref = NULL;
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
if (ss == gfc_ss_terminator) if (expr->rank == 0)
{ {
/* Transfer a scalar value. */ /* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr); gfc_conv_expr_reference (&se, expr);
@ -2281,7 +2277,7 @@ gfc_trans_transfer (gfc_code * code)
else else
{ {
/* Get the descriptor. */ /* 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); tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
} }
@ -2290,6 +2286,7 @@ gfc_trans_transfer (gfc_code * code)
} }
/* Initialize the scalarizer. */ /* Initialize the scalarizer. */
ss = gfc_walk_expr (expr);
gfc_init_loopinfo (&loop); gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss); gfc_add_ss_to_loop (&loop, ss);

18
gcc/fortran/trans-stmt.c
View File

@ -274,7 +274,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
/* Obtain the argument descriptor for unpacking. */ /* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL); gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1; 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); gfc_add_block_to_block (&se->pre, &parmse.pre);
/* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
@ -864,9 +864,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
"implemented for image-set at %L", "implemented for image-set at %L",
gfc_c_int_kind, &code->expr1->where); gfc_c_int_kind, &code->expr1->where);
gfc_conv_array_parameter (&se, code->expr1, gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
gfc_walk_expr (code->expr1), true, NULL,
NULL, &len);
images = se.expr; images = se.expr;
tmp = gfc_typenode_for_spec (&code->expr1->ts); tmp = gfc_typenode_for_spec (&code->expr1->ts);
@ -1160,7 +1158,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable)) && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{ {
gfc_se se; gfc_se se;
gfc_ss *ss;
tree desc; tree desc;
desc = sym->backend_decl; desc = sym->backend_decl;
@ -1168,13 +1165,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* If association is to an expression, evaluate it and create temporary. /* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */ Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
ss = gfc_walk_expr (e);
if (sym->assoc->variable) if (sym->assoc->variable)
{ {
se.direct_byref = 1; se.direct_byref = 1;
se.expr = desc; 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 /* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */ descriptor to the one generated for the temporary. */
@ -1229,7 +1225,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{ {
/* For a class array we need a descriptor for the selector. */ /* 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. */ /* Obtain a temporary class container for the result. */
gfc_conv_class_to_class (&se, e, sym->ts, false); gfc_conv_class_to_class (&se, e, sym->ts, false);
@ -3502,8 +3498,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
gfc_init_se (&lse, NULL); gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count, NULL); lse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.direct_byref = 1; lse.direct_byref = 1;
rss = gfc_walk_expr (expr2); gfc_conv_expr_descriptor (&lse, expr2);
gfc_conv_expr_descriptor (&lse, expr2, rss);
gfc_add_block_to_block (&body, &lse.pre); gfc_add_block_to_block (&body, &lse.pre);
gfc_add_block_to_block (&body, &lse.post); gfc_add_block_to_block (&body, &lse.post);
@ -3524,9 +3519,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
gfc_add_modify (block, count, gfc_index_zero_node); gfc_add_modify (block, count, gfc_index_zero_node);
parm = gfc_build_array_ref (tmp1, count, NULL); parm = gfc_build_array_ref (tmp1, count, NULL);
lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL); 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_add_modify (&lse.pre, lse.expr, parm);
gfc_start_block (&body); gfc_start_block (&body);
gfc_add_block_to_block (&body, &lse.pre); gfc_add_block_to_block (&body, &lse.pre);