mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 19:51:34 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2007-10-29  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/31217
        PR fortran/33811
        PR fortran/33686
        * trans-array.c (gfc_conv_loop_setup): Send a complete type to
        gfc_trans_create_temp_array if the temporary is character.
        * trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
        allocate_temp_for_forall_nest.
        (forall_replace): New function.
        (forall_replace_symtree): New function.
        (forall_restore): New function.
        (forall_restore_symtree): New function.
        (forall_make_variable_temp): New function.
        (check_forall_dependencies): New function.
        (cleanup_forall_symtrees): New function.
        gfc_trans_forall_1): Add and initialize pre and post blocks.
        Call check_forall_dependencies to check for all dependencies
        and either trigger second forall block to copy temporary or
        copy lval, outside the forall construct and replace all
        dependent references. After assignment clean-up and coalesce
        the blocks at the end of the function.
        * gfortran.h : Add prototypes for gfc_traverse_expr and
        find_forall_index.
        expr.c (gfc_traverse_expr): New function to traverse expression
        and visit all subexpressions, under control of a logical flag,
        a symbol and an integer pointer. The slave function is caller
        defined and is only called on EXPR_VARIABLE.
        (expr_set_symbols_referenced): Called by above to set symbols
        referenced.
        (gfc_expr_set_symbols_referenced): Rework of this function to
        use two new functions above.
        * resolve.c (find_forall_index): Rework with gfc_traverse_expr,
        using forall_index.
        (forall_index): New function used by previous.
        * dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
        all references, not just REF_ARRAY.
        (gfc_dep_resolver): Correct the logic for substrings so that
        overlapping arrays are handled correctly.

2007-10-29 Paul Thomas <pault@gcc.gnu.org>

        PR fortran/31217
        PR fortran/33811
        * gfortran.dg/forall_12.f90: New test.

        PR fortran/33686
        * gfortran.dg/forall_13.f90: New test.

From-SVN: r129720
This commit is contained in:
Paul Thomas 2007-10-29 14:13:44 +00:00 committed by Tobias Burnus
parent a270181e40
commit 640670c7f4
10 changed files with 451 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/fortran/ChangeLog
View File

@ -1,3 +1,44 @@
2007-10-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31217
PR fortran/33811
PR fortran/33686
* trans-array.c (gfc_conv_loop_setup): Send a complete type to
gfc_trans_create_temp_array if the temporary is character.
* trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
allocate_temp_for_forall_nest.
(forall_replace): New function.
(forall_replace_symtree): New function.
(forall_restore): New function.
(forall_restore_symtree): New function.
(forall_make_variable_temp): New function.
(check_forall_dependencies): New function.
(cleanup_forall_symtrees): New function.
gfc_trans_forall_1): Add and initialize pre and post blocks.
Call check_forall_dependencies to check for all dependencies
and either trigger second forall block to copy temporary or
copy lval, outside the forall construct and replace all
dependent references. After assignment clean-up and coalesce
the blocks at the end of the function.
* gfortran.h : Add prototypes for gfc_traverse_expr and
find_forall_index.
expr.c (gfc_traverse_expr): New function to traverse expression
and visit all subexpressions, under control of a logical flag,
a symbol and an integer pointer. The slave function is caller
defined and is only called on EXPR_VARIABLE.
(expr_set_symbols_referenced): Called by above to set symbols
referenced.
(gfc_expr_set_symbols_referenced): Rework of this function to
use two new functions above.
* resolve.c (find_forall_index): Rework with gfc_traverse_expr,
using forall_index.
(forall_index): New function used by previous.
* dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
all references, not just REF_ARRAY.
(gfc_dep_resolver): Correct the logic for substrings so that
overlapping arrays are handled correctly.
2007-10-28 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/32147

8
gcc/fortran/dependency.c
View File

@ -657,8 +657,7 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
/* Identical and disjoint ranges return 0,
overlapping ranges return 1. */
/* Return zero if we refer to the same full arrays. */
if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
if (expr1->ref && expr2->ref)
return gfc_dep_resolver (expr1->ref, expr2->ref);
return 1;
@ -1197,8 +1196,9 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
break;
case REF_SUBSTRING:
/* Substring overlaps are handled by the string assignment code. */
return 0;
/* Substring overlaps are handled by the string assignment code
if there is not an underlying dependency. */
return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
case REF_ARRAY:
if (lref->u.ar.dimen != rref->u.ar.dimen)

98
gcc/fortran/expr.c
View File

@ -2998,32 +2998,36 @@ gfc_get_variable_expr (gfc_symtree *var)
}
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
/* General expression traversal function. */
void
gfc_expr_set_symbols_referenced (gfc_expr *expr)
bool
gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
bool (*func)(gfc_expr *, gfc_symbol *, int*),
int f)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
gfc_array_ref ar;
gfc_ref *ref;
gfc_actual_arglist *args;
gfc_constructor *c;
int i;
if (!expr) return;
if (!expr)
return false;
switch (expr->expr_type)
{
case EXPR_OP:
gfc_expr_set_symbols_referenced (expr->value.op.op1);
gfc_expr_set_symbols_referenced (expr->value.op.op2);
break;
case EXPR_VARIABLE:
gcc_assert (expr->symtree->n.sym);
if ((*func) (expr, sym, &f))
return true;
case EXPR_FUNCTION:
for (arg = expr->value.function.actual; arg; arg = arg->next)
gfc_expr_set_symbols_referenced (arg->expr);
break;
case EXPR_VARIABLE:
gfc_set_sym_referenced (expr->symtree->n.sym);
for (args = expr->value.function.actual; args; args = args->next)
{
if (gfc_traverse_expr (args->expr, sym, func, f))
return true;
}
break;
case EXPR_CONSTANT:
@ -3037,33 +3041,67 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
gfc_expr_set_symbols_referenced (c->expr);
break;
case EXPR_OP:
if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
return true;
if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
return true;
break;
default:
gcc_unreachable ();
break;
}
for (ref = expr->ref; ref; ref = ref->next)
ref = expr->ref;
while (ref != NULL)
{
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
case REF_ARRAY:
ar = ref->u.ar;
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
{
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
if (gfc_traverse_expr (ar.start[i], sym, func, f))
return true;
if (gfc_traverse_expr (ar.end[i], sym, func, f))
return true;
if (gfc_traverse_expr (ar.stride[i], sym, func, f))
return true;
}
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
gfc_expr_set_symbols_referenced (ref->u.ss.start);
gfc_expr_set_symbols_referenced (ref->u.ss.end);
if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
return true;
if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
return true;
break;
case REF_COMPONENT:
break;
default:
gcc_unreachable ();
break;
}
ref = ref->next;
}
return false;
}
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
static bool
expr_set_symbols_referenced (gfc_expr *expr,
gfc_symbol *sym ATTRIBUTE_UNUSED,
int *f ATTRIBUTE_UNUSED)
{
gfc_set_sym_referenced (expr->symtree->n.sym);
return false;
}
void
gfc_expr_set_symbols_referenced (gfc_expr *expr)
{
gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
}

4
gcc/fortran/gfortran.h
View File

@ -2233,6 +2233,9 @@ try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
bool (*)(gfc_expr *, gfc_symbol *, int*),
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
/* st.c */
@ -2252,6 +2255,7 @@ int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
int gfc_elemental (gfc_symbol *);
try gfc_resolve_iterator (gfc_iterator *, bool);
try find_forall_index (gfc_expr *, gfc_symbol *, int);
try gfc_resolve_index (gfc_expr *, int);
try gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);

156
gcc/fortran/resolve.c
View File

@ -4322,131 +4322,39 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
}
/* Traversal function for find_forall_index. f == 2 signals that
that variable itself is not to be checked - only the references. */
static bool
forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
{
gcc_assert (expr->expr_type == EXPR_VARIABLE);
/* A scalar assignment */
if (!expr->ref || *f == 1)
{
if (expr->symtree->n.sym == sym)
return true;
else
return false;
}
if (*f == 2)
*f = 1;
return false;
}
/* Check whether the FORALL index appears in the expression or not.
Returns SUCCESS if SYM is found in EXPR. */
static try
find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
try
find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
{
gfc_array_ref ar;
gfc_ref *tmp;
gfc_actual_arglist *args;
int i;
if (!expr)
if (gfc_traverse_expr (expr, sym, forall_index, f))
return SUCCESS;
else
return FAILURE;
switch (expr->expr_type)
{
case EXPR_VARIABLE:
gcc_assert (expr->symtree->n.sym);
/* A scalar assignment */
if (!expr->ref)
{
if (expr->symtree->n.sym == symbol)
return SUCCESS;
else
return FAILURE;
}
/* the expr is array ref, substring or struct component. */
tmp = expr->ref;
while (tmp != NULL)
{
switch (tmp->type)
{
case REF_ARRAY:
/* Check if the symbol appears in the array subscript. */
ar = tmp->u.ar;
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
{
if (ar.start[i])
if (find_forall_index (ar.start[i], symbol) == SUCCESS)
return SUCCESS;
if (ar.end[i])
if (find_forall_index (ar.end[i], symbol) == SUCCESS)
return SUCCESS;
if (ar.stride[i])
if (find_forall_index (ar.stride[i], symbol) == SUCCESS)
return SUCCESS;
} /* end for */
break;
case REF_SUBSTRING:
if (expr->symtree->n.sym == symbol)
return SUCCESS;
tmp = expr->ref;
/* Check if the symbol appears in the substring section. */
if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
return SUCCESS;
if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
return SUCCESS;
break;
case REF_COMPONENT:
break;
default:
gfc_error("expression reference type error at %L", &expr->where);
}
tmp = tmp->next;
}
break;
/* If the expression is a function call, then check if the symbol
appears in the actual arglist of the function. */
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
{
if (find_forall_index(args->expr,symbol) == SUCCESS)
return SUCCESS;
}
break;
/* It seems not to happen. */
case EXPR_SUBSTRING:
if (expr->ref)
{
tmp = expr->ref;
gcc_assert (expr->ref->type == REF_SUBSTRING);
if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
return SUCCESS;
if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
return SUCCESS;
}
break;
/* It seems not to happen. */
case EXPR_STRUCTURE:
case EXPR_ARRAY:
gfc_error ("Unsupported statement while finding forall index in "
"expression");
break;
case EXPR_OP:
/* Find the FORALL index in the first operand. */
if (expr->value.op.op1)
{
if (find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
return SUCCESS;
}
/* Find the FORALL index in the second operand. */
if (expr->value.op.op2)
{
if (find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
return SUCCESS;
}
break;
default:
break;
}
return FAILURE;
}
@ -4502,11 +4410,11 @@ resolve_forall_iterators (gfc_forall_iterator *it)
for (iter2 = iter; iter2; iter2 = iter2->next)
{
if (find_forall_index (iter2->start,
iter->var->symtree->n.sym) == SUCCESS
iter->var->symtree->n.sym, 0) == SUCCESS
|| find_forall_index (iter2->end,
iter->var->symtree->n.sym) == SUCCESS
iter->var->symtree->n.sym, 0) == SUCCESS
|| find_forall_index (iter2->stride,
iter->var->symtree->n.sym) == SUCCESS)
iter->var->symtree->n.sym, 0) == SUCCESS)
gfc_error ("FORALL index '%s' may not appear in triplet "
"specification at %L", iter->var->symtree->name,
&iter2->start->where);
@ -5726,7 +5634,7 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
/* If one of the FORALL index variables doesn't appear in the
assignment target, then there will be a many-to-one
assignment. */
if (find_forall_index (code->expr, forall_index) == FAILURE)
if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
gfc_error ("The FORALL with index '%s' cause more than one "
"assignment to this object at %L",
var_expr[n]->symtree->name, &code->expr->where);

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

@ -3376,6 +3376,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
if (loop->temp_ss != NULL)
{
gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
/* Make absolutely sure that this is a complete type. */
if (loop->temp_ss->string_length)
loop->temp_ss->data.temp.type
= gfc_get_character_type_len (gfc_default_character_kind,
loop->temp_ss->string_length);
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;

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

@ -1510,6 +1510,205 @@ gfc_trans_select (gfc_code * code)
}
/* Traversal function to substitute a replacement symtree if the symbol
in the expression is the same as that passed. f == 2 signals that
that variable itself is not to be checked - only the references.
This group of functions is used when the variable expression in a
FORALL assignment has internal references. For example:
FORALL (i = 1:4) p(p(i)) = i
The only recourse here is to store a copy of 'p' for the index
expression. */
static gfc_symtree *new_symtree;
static gfc_symtree *old_symtree;
static bool
forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
{
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (*f == 2)
*f = 1;
else if (expr->symtree->n.sym == sym)
expr->symtree = new_symtree;
return false;
}
static void
forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
{
gfc_traverse_expr (e, sym, forall_replace, f);
}
static bool
forall_restore (gfc_expr *expr,
gfc_symbol *sym ATTRIBUTE_UNUSED,
int *f ATTRIBUTE_UNUSED)
{
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (expr->symtree == new_symtree)
expr->symtree = old_symtree;
return false;
}
static void
forall_restore_symtree (gfc_expr *e)
{
gfc_traverse_expr (e, NULL, forall_restore, 0);
}
static void
forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
{
gfc_se tse;
gfc_se rse;
gfc_expr *e;
gfc_symbol *new_sym;
gfc_symbol *old_sym;
gfc_symtree *root;
tree tmp;
/* Build a copy of the lvalue. */
old_symtree = c->expr->symtree;
old_sym = old_symtree->n.sym;
e = gfc_lval_expr_from_sym (old_sym);
if (old_sym->attr.dimension)
{
gfc_init_se (&tse, NULL);
gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
gfc_add_block_to_block (pre, &tse.pre);
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref (tse.expr);
if (e->ts.type != BT_CHARACTER)
{
/* Use the variable offset for the temporary. */
tmp = gfc_conv_descriptor_offset (tse.expr);
gfc_add_modify_expr (pre, tmp,
gfc_conv_array_offset (old_sym->backend_decl));
}
}
else
{
gfc_init_se (&tse, NULL);
gfc_init_se (&rse, NULL);
gfc_conv_expr (&rse, e);
if (e->ts.type == BT_CHARACTER)
{
tse.string_length = rse.string_length;
tmp = gfc_get_character_type_len (gfc_default_character_kind,
tse.string_length);
tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
rse.string_length);
gfc_add_block_to_block (pre, &tse.pre);
gfc_add_block_to_block (post, &tse.post);
}
else
{
tmp = gfc_typenode_for_spec (&e->ts);
tse.expr = gfc_create_var (tmp, "temp");
}
tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
e->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (pre, tmp);
}
gfc_free_expr (e);
/* Create a new symbol to represent the lvalue. */
new_sym = gfc_new_symbol (old_sym->name, NULL);
new_sym->ts = old_sym->ts;
new_sym->attr.referenced = 1;
new_sym->attr.dimension = old_sym->attr.dimension;
new_sym->attr.flavor = old_sym->attr.flavor;
/* Use the temporary as the backend_decl. */
new_sym->backend_decl = tse.expr;
/* Create a fake symtree for it. */
root = NULL;
new_symtree = gfc_new_symtree (&root, old_sym->name);
new_symtree->n.sym = new_sym;
gcc_assert (new_symtree == root);
/* Go through the expression reference replacing the old_symtree
with the new. */
forall_replace_symtree (c->expr, old_sym, 2);
/* Now we have made this temporary, we might as well use it for
the right hand side. */
forall_replace_symtree (c->expr2, old_sym, 1);
}
/* Handles dependencies in forall assignments. */
static int
check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
{
gfc_ref *lref;
gfc_ref *rref;
int need_temp;
gfc_symbol *lsym;
lsym = c->expr->symtree->n.sym;
need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
/* Now check for dependencies within the 'variable'
expression itself. These are treated by making a complete
copy of variable and changing all the references to it
point to the copy instead. Note that the shallow copy of
the variable will not suffice for derived types with
pointer components. We therefore leave these to their
own devices. */
if (lsym->ts.type == BT_DERIVED
&& lsym->ts.derived->attr.pointer_comp)
return need_temp;
new_symtree = NULL;
if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
{
forall_make_variable_temp (c, pre, post);
need_temp = 0;
}
/* Substrings with dependencies are treated in the same
way. */
if (c->expr->ts.type == BT_CHARACTER
&& c->expr->ref
&& c->expr2->expr_type == EXPR_VARIABLE
&& lsym == c->expr2->symtree->n.sym)
{
for (lref = c->expr->ref; lref; lref = lref->next)
if (lref->type == REF_SUBSTRING)
break;
for (rref = c->expr2->ref; rref; rref = rref->next)
if (rref->type == REF_SUBSTRING)
break;
if (rref && lref
&& gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
{
forall_make_variable_temp (c, pre, post);
need_temp = 0;
}
}
return need_temp;
}
static void
cleanup_forall_symtrees (gfc_code *c)
{
forall_restore_symtree (c->expr);
forall_restore_symtree (c->expr2);
gfc_free (new_symtree->n.sym);
gfc_free (new_symtree);
}
/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
indicates whether we should generate code to test the FORALLs mask
@ -2172,7 +2371,20 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
type = gfc_typenode_for_spec (&expr1->ts);
if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
{
if (!expr1->ts.cl->backend_decl)
{
gfc_se tse;
gfc_init_se (&tse, NULL);
gfc_conv_expr (&tse, expr1->ts.cl->length);
expr1->ts.cl->backend_decl = tse.expr;
}
type = gfc_get_character_type_len (gfc_default_character_kind,
expr1->ts.cl->backend_decl);
}
else
type = gfc_typenode_for_spec (&expr1->ts);
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
@ -2412,6 +2624,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
static tree
gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
{
stmtblock_t pre;
stmtblock_t post;
stmtblock_t block;
stmtblock_t body;
tree *var;
@ -2459,7 +2673,9 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Allocate the space for info. */
info = (forall_info *) gfc_getmem (sizeof (forall_info));
gfc_start_block (&block);
gfc_start_block (&pre);
gfc_init_block (&post);
gfc_init_block (&block);
n = 0;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
@ -2619,8 +2835,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
switch (c->op)
{
case EXEC_ASSIGN:
/* A scalar or array assignment. */
need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
/* A scalar or array assignment. DO the simple check for
lhs to rhs dependencies. These make a temporary for the
rhs and form a second forall block to copy to variable. */
need_temp = check_forall_dependencies(c, &pre, &post);
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
if (need_temp)
@ -2637,6 +2856,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_add_expr_to_block (&block, tmp);
}
/* Cleanup any temporary symtrees that have been made to deal
with dependencies. */
if (new_symtree)
cleanup_forall_symtrees (c);
break;
case EXEC_WHERE:
@ -2706,7 +2930,10 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
if (maskindex)
pushdecl (maskindex);
return gfc_finish_block (&block);
gfc_add_block_to_block (&pre, &block);
gfc_add_block_to_block (&pre, &post);
return gfc_finish_block (&pre);
}

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2007-10-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31217
PR fortran/33811
* gfortran.dg/forall_12.f90: New test.
PR fortran/33686
* gfortran.dg/forall_13.f90: New test.
2007-10-28 Paolo Carlini <pcarlini@suse.de>
Mark Mitchell <mark@codesourcery.com>

40
gcc/testsuite/gfortran.dg/forall_12.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
! Tests the fix for PR31217 and PR33811 , in which dependencies were not
! correctly handled for the assignments below and, when this was fixed,
! the last two ICEd on trying to create the temorary.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
! Dominique d'Humieres <dominiq@lps.ens.fr>
! and Paul Thomas <pault@gcc.gnu.org>
!
character(len=1) :: a = "1"
character(len=1) :: b(4) = (/"1","2","3","4"/), c(4)
c = b
forall(i=1:1) a(i:i) = a(i:i) ! This was the original PR31217
forall(i=1:1) b(i:i) = b(i:i) ! The rest were found to be broken
forall(i=1:1) b(:)(i:i) = b(:)(i:i)
forall(i=1:1) b(1:3)(i:i) = b(2:4)(i:i)
if (any (b .ne. (/"2","3","4","4"/))) call abort ()
b = c
forall(i=1:1) b(2:4)(i:i) = b(1:3)(i:i)
if (any (b .ne. (/"1","1","2","3"/))) call abort ()
b = c
do i = 1, 1
b(2:4)(i:i) = b(1:3)(i:i) ! This was PR33811 and Paul's bit
end do
if (any (b .ne. (/"1","1","2","3"/))) call abort ()
call foo
contains
subroutine foo
character(LEN=12) :: a(2) = "123456789012"
character(LEN=12) :: b = "123456789012"
! These are Dominique's
forall (i = 3:10) a(:)(i:i+2) = a(:)(i-2:i)
IF (a(1) .ne. "121234567890") CALL abort ()
forall (i = 3:10) a(2)(i:i+2) = a(1)(i-2:i)
IF (a(2) .ne. "121212345678") call abort ()
forall (i = 3:10) b(i:i+2) = b(i-2:i)
IF (b .ne. "121234567890") CALL abort ()
end subroutine
end

14
gcc/testsuite/gfortran.dg/forall_13.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do run }
! Tests the fix for PR33686, in which dependencies were not
! correctly handled for the assignments below.
!
! Contributed by Dick Hendrickson on comp.lang.fortran,
! " Most elegant syntax for inverting a permutation?" 20071006
!
integer :: p(4) = (/2,4,1,3/)
forall (i = 1:4) p(p(i)) = i ! This was the original
if (any (p .ne. (/3,1,4,2/))) call abort ()
forall (i = 1:4) p(5 - p(i)) = p(5 - i) ! This is a more complicated version
if (any (p .ne. (/1,2,3,4/))) call abort ()
end