This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR31217 - ICE using FORALL on character substrings
Well here is the resubmission, in response to Dominique's failing case,
and, just to show that our's is a policy of continuous improvement, it
fixes PR33686 as well.
This latter was triggered by a contribution from Dick Hendrickson on
comp.lang.fortran, under " Most elegant syntax for inverting a
permutation?" 20071006:
integer :: p(4) = (/2,4,1,3/)
forall (i = 1:4) p(p(i)) = i
print *, p
end
This gave a wrong answer because the dependency internal to the 'value'
expression was not resolved. Since, in principle, this dependency could
span all and any of the references, in any combinantion, the only way to
cope is to copy the whole array to a temporary, ouside of the FORALL
construct, associate a symtree to it and replace the original symtree in
all references.
Dominique's
character(LEN=12) :: b = "123456789012"
forall (i = 3:10) b(i:i+2) = b(i-2:i)
IF (b .ne. "121234567890") CALL abort ()
END
is solved in the same fashion.
Whilst it is a bit of a grind, this part of the patch is straightforward
and relatively easily understood from the patch to trans-stmt.c and the
ChangeLog. Note that the fix for assignments (PR33811) remains as it
was in the original submission. A lot of the symbol/symtree code was
lifted directly from Richard Sandiford's interface routines in
trans-expr.c. Unfortunately, these did not seem to be readily liftable
for this patch.
In the course of writing this patch, I found myself needing to write yet
another function to traverse an expression and all its sub-expressions,
comparing EXPR_VARIABLE with a symbol and doing something if they are
the same. I therefore did something that I have meant to do for a long
time and that is to write a general expression traverser,
gfc_traverse_expr. As soon as this patch is put to bed, I will clean up
the several other cases that can use this general function. In
addition, there is at least one more to come - the pureness of statement
functions, PR29389.
Regtested on Cygwin_NT/amd64 - will repeat on x86_ia64 just as soon as I
get home.
OK for trunk?
Paul
2007-10-25 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-25 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,1711 ----
}
+ /* 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. */
+ new_symtree = NULL;
+ if ((find_forall_index (c->expr, lsym, 2) == SUCCESS)
+ && !lsym->attr.pointer_comp)
+ {
+ 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. */
--- 2368,2387 ----
&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 ****
--- 2621,2628 ----
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)
--- 2670,2678 ----
/* 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)
--- 2832,2842 ----
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 ****
--- 2853,2863 ----
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);
}
--- 2927,2936 ----
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