This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, fortran] PR31217 - ICE using FORALL on character substrings
FX Coudert wrote:
>> Looking at the patch, it think it is OK. (Though, I would not mind if
>> someone else could glance over the patch as it is rather large.)
> I haven't gone into the details, but it looks OK to me too, so let's
> get it committed and see what it breaks :)
Attached is the new version of Paul's patch, which he send me and
Dominique this morning in a private mail. (The patch contained also a
fix of PR33897, which I intent to extract and to post later.)
The attached patch is essentially the same as the one posted on 26
October, http://gcc.gnu.org/ml/fortran/2007-10/msg00341.html, except for
a fix in trans-stmt.c (see below). The previous patch plus the half of
the fix were approved yesterday by me, and FX also glanced over it.
(Build and regression tested on x86-64-linux.)
I intent to commit it in 24h unless someone approves it earlier - or has
objections.
Tobias
Interdiff for trans-stmt.c between Paul's 26 October patch and his new
patch/the attached patch:
diff -u gcc/fortran/trans-stmt.c gcc/fortran/trans-stmt.c
--- gcc/fortran/trans-stmt.c (working copy)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -1663,9 +1663,12 @@
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)
- && !lsym->attr.pointer_comp)
+ if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
{
forall_make_variable_temp (c, pre, post);
need_temp = 0;
The patch contained, additionally, changes to decl.c, parse.c and
contained_3.f90 for PR33897 and the following patch which seems to be
unrelated to either PR. (These changes are not in the attached patch.)
--- gcc/fortran/trans-intrinsic.c (revision 129504)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -3171,8 +3171,6 @@ gfc_conv_intrinsic_array_transfer (gfc_s
{
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
tmp, dest_word_len);
- tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
- tmp, source_bytes);
}
else
tmp = source_bytes;
@@ -3229,7 +3227,7 @@ gfc_conv_intrinsic_array_transfer (gfc_s
3,
tmp,
fold_convert (pvoid_type_node, source),
- size_bytes);
+ source_bytes);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = info->descriptor;
2007-10-28 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 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.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 129505)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 3376,3381 ****
--- 3376,3388 ----
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;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 129504)
--- gcc/fortran/gfortran.h (working copy)
*************** try gfc_check_assign_symbol (gfc_symbol
*** 2233,2238 ****
--- 2233,2241 ----
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 */
*************** int gfc_impure_variable (gfc_symbol *);
*** 2252,2257 ****
--- 2255,2261 ----
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 129504)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_select (gfc_code * code)
*** 1510,1515 ****
--- 1510,1714 ----
}
+ /* 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
*************** gfc_trans_assign_need_temp (gfc_expr * e
*** 2172,2178 ****
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
! type = gfc_typenode_for_spec (&expr1->ts);
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
--- 2371,2390 ----
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
! 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. */
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2412,2417 ****
--- 2624,2631 ----
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;
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2459,2465 ****
/* Allocate the space for info. */
info = (forall_info *) gfc_getmem (sizeof (forall_info));
! gfc_start_block (&block);
n = 0;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
--- 2673,2681 ----
/* Allocate the space for info. */
info = (forall_info *) gfc_getmem (sizeof (forall_info));
! gfc_start_block (&pre);
! gfc_init_block (&post);
! gfc_init_block (&block);
n = 0;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2619,2626 ****
switch (c->op)
{
case EXEC_ASSIGN:
! /* A scalar or array assignment. */
! need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
if (need_temp)
--- 2835,2845 ----
switch (c->op)
{
case EXEC_ASSIGN:
! /* 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)
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2637,2642 ****
--- 2856,2866 ----
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:
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2706,2712 ****
if (maskindex)
pushdecl (maskindex);
! return gfc_finish_block (&block);
}
--- 2930,2939 ----
if (maskindex)
pushdecl (maskindex);
! gfc_add_block_to_block (&pre, &block);
! gfc_add_block_to_block (&pre, &post);
!
! return gfc_finish_block (&pre);
}
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 129504)
--- gcc/fortran/expr.c (working copy)
*************** gfc_get_variable_expr (gfc_symtree *var)
*** 2998,3029 ****
}
! /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
! void
! gfc_expr_set_symbols_referenced (gfc_expr *expr)
{
! gfc_actual_arglist *arg;
! gfc_constructor *c;
gfc_ref *ref;
int i;
! if (!expr) return;
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_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);
break;
case EXPR_CONSTANT:
--- 2998,3033 ----
}
! /* General expression traversal function. */
! bool
! gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
! bool (*func)(gfc_expr *, gfc_symbol *, int*),
! int f)
{
! gfc_array_ref ar;
gfc_ref *ref;
+ gfc_actual_arglist *args;
+ gfc_constructor *c;
int i;
! if (!expr)
! return false;
switch (expr->expr_type)
{
! case EXPR_VARIABLE:
! gcc_assert (expr->symtree->n.sym);
! if ((*func) (expr, sym, &f))
! return true;
! case EXPR_FUNCTION:
! 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:
*************** gfc_expr_set_symbols_referenced (gfc_exp
*** 3037,3069 ****
gfc_expr_set_symbols_referenced (c->expr);
break;
default:
gcc_unreachable ();
break;
}
! for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
! case REF_ARRAY:
! for (i = 0; i < ref->u.ar.dimen; 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]);
}
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);
break;
!
default:
gcc_unreachable ();
- break;
}
}
--- 3041,3107 ----
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;
}
! ref = expr->ref;
! while (ref != NULL)
! {
switch (ref->type)
{
! case REF_ARRAY:
! ar = ref->u.ar;
! for (i = 0; i < GFC_MAX_DIMENSIONS; 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_SUBSTRING:
! 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 ();
}
+ 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);
}
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 129504)
--- gcc/fortran/resolve.c (working copy)
*************** gfc_resolve_iterator (gfc_iterator *iter
*** 4322,4452 ****
}
! /* 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)
{
! gfc_array_ref ar;
! gfc_ref *tmp;
! gfc_actual_arglist *args;
! int i;
!
! if (!expr)
! 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;
}
--- 4322,4360 ----
}
! /* 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. */
! try
! find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
! {
! if (gfc_traverse_expr (expr, sym, forall_index, f))
! return SUCCESS;
! else
! return FAILURE;
}
*************** resolve_forall_iterators (gfc_forall_ite
*** 4502,4512 ****
for (iter2 = iter; iter2; iter2 = iter2->next)
{
if (find_forall_index (iter2->start,
! iter->var->symtree->n.sym) == SUCCESS
|| find_forall_index (iter2->end,
! iter->var->symtree->n.sym) == SUCCESS
|| find_forall_index (iter2->stride,
! iter->var->symtree->n.sym) == SUCCESS)
gfc_error ("FORALL index '%s' may not appear in triplet "
"specification at %L", iter->var->symtree->name,
&iter2->start->where);
--- 4410,4420 ----
for (iter2 = iter; iter2; iter2 = iter2->next)
{
if (find_forall_index (iter2->start,
! iter->var->symtree->n.sym, 0) == SUCCESS
|| find_forall_index (iter2->end,
! iter->var->symtree->n.sym, 0) == SUCCESS
|| find_forall_index (iter2->stride,
! 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);
*************** gfc_resolve_assign_in_forall (gfc_code *
*** 5726,5732 ****
/* 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)
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);
--- 5634,5640 ----
/* 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, 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);
Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c (revision 129504)
--- gcc/fortran/dependency.c (working copy)
*************** gfc_check_dependency (gfc_expr *expr1, g
*** 657,664 ****
/* 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)
return gfc_dep_resolver (expr1->ref, expr2->ref);
return 1;
--- 657,663 ----
/* Identical and disjoint ranges return 0,
overlapping ranges return 1. */
! if (expr1->ref && expr2->ref)
return gfc_dep_resolver (expr1->ref, expr2->ref);
return 1;
*************** gfc_dep_resolver (gfc_ref *lref, gfc_ref
*** 1197,1204 ****
break;
case REF_SUBSTRING:
! /* Substring overlaps are handled by the string assignment code. */
! return 0;
case REF_ARRAY:
if (lref->u.ar.dimen != rref->u.ar.dimen)
--- 1196,1204 ----
break;
case REF_SUBSTRING:
! /* 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)
Index: gcc/testsuite/gfortran.dg/forall_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_12.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/forall_12.f90 (revision 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
+
Index: gcc/testsuite/gfortran.dg/forall_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_13.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/forall_13.f90 (revision 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