diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/fortran/dependency.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 98 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 150 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 237 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/forall_12.f90 | 40 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/forall_13.f90 | 14 |
10 files changed, 448 insertions, 160 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c75af08..a761a95 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 1c5bf04..29a5237 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -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) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2edf7ad..c7edb49 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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); - 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: @@ -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); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 347cced..bc8fad6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 582bb92..69d2c51 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4322,131 +4322,39 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok) } -/* 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; } @@ -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); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 680d3b4..1c47b24 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0bf0387..cbb15a5 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cecd5f0..5c533f3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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> diff --git a/gcc/testsuite/gfortran.dg/forall_12.f90 b/gcc/testsuite/gfortran.dg/forall_12.f90 new file mode 100644 index 0000000..207977c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/forall_12.f90 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/forall_13.f90 b/gcc/testsuite/gfortran.dg/forall_13.f90 new file mode 100644 index 0000000..97f6062 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/forall_13.f90 @@ -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 |