Commit 2960a368 by Tobias Burnus Committed by Tobias Burnus

re PR fortran/54350 (FAIL: gfortran.dg/realloc_on_assign_*.f90 -O (internal…

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
parent 3c5e0cc4
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,
......
...@@ -510,40 +510,36 @@ gfc_free_ss_chain (gfc_ss * ss) ...@@ -510,40 +510,36 @@ 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);
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) switch (ss_info->type)
{ {
case GFC_SS_SECTION: case GFC_SS_SECTION:
for (n = 0; n < ss->dimen; n++) for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{ if (ss_info->data.array.subscript[n])
if (ss_info->data.array.subscript[ss->dim[n]]) gfc_free_ss_chain (ss_info->data.array.subscript[n]);
gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
}
break; break;
default: default:
break; 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); free (ss);
} }
...@@ -1805,7 +1801,6 @@ static void ...@@ -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) ...@@ -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, ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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),
......
...@@ -131,9 +131,9 @@ void gfc_conv_tmp_array_ref (gfc_se * se); ...@@ -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 *);
......
...@@ -304,7 +304,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -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) ...@@ -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,8 +3385,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, ...@@ -3385,8 +3385,7 @@ 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)
{ {
if (arg->expr->rank == 0) if (arg->expr->rank == 0)
...@@ -3404,9 +3403,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -3818,11 +3811,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
} }
else else
{ {
/* A scalar or transformational function. */ bool scalar;
gfc_init_se (&parmse, NULL); 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); 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 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, ...@@ -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, ...@@ -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, ...@@ -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, ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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)
{ break;
remap->u.ar.type = AR_FULL;
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) ...@@ -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) ...@@ -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 ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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);
} }
......
...@@ -664,7 +664,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) ...@@ -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, ...@@ -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, ...@@ -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) ...@@ -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,15 +2277,16 @@ gfc_trans_transfer (gfc_code * code) ...@@ -2281,15 +2277,16 @@ 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);
} }
transfer_array_desc (&se, &expr->ts, tmp); transfer_array_desc (&se, &expr->ts, tmp);
goto finish_block_label; goto finish_block_label;
} }
/* 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);
......
...@@ -274,7 +274,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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) ...@@ -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, ...@@ -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, ...@@ -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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment