+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
/* 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;
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)
}
-/* 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);
- case EXPR_FUNCTION:
- for (arg = expr->value.function.actual; arg; arg = arg->next)
- gfc_expr_set_symbols_referenced (arg->expr);
- break;
+ if ((*func) (expr, sym, &f))
+ return true;
- case EXPR_VARIABLE:
- gfc_set_sym_referenced (expr->symtree->n.sym);
+ 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 (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);
}
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_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);
}
-/* Check whether the FORALL index appears in the expression or not.
- Returns SUCCESS if SYM is found in EXPR. */
+/* Traversal function for find_forall_index. f == 2 signals that
+ that variable itself is not to be checked - only the references. */
-static try
-find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
+static bool
+forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
{
- gfc_array_ref ar;
- gfc_ref *tmp;
- gfc_actual_arglist *args;
- int i;
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
- if (!expr)
- return FAILURE;
-
- switch (expr->expr_type)
+ /* A scalar assignment */
+ if (!expr->ref || *f == 1)
{
- 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;
+ if (expr->symtree->n.sym == sym)
+ return true;
+ else
+ return false;
+ }
- 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;
- }
+ if (*f == 2)
+ *f = 1;
+ return false;
+}
- /* 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;
- }
+/* Check whether the FORALL index appears in the expression or not.
+ Returns SUCCESS if SYM is found in EXPR. */
- return FAILURE;
+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;
}
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);
/* 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);
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;
}
+/* 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
&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. */
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;
/* 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)
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)
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:
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);
}
+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>
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
projects / gcc.git / commitdiff