diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/fortran/dependency.c | 49 | ||||
| -rw-r--r-- | gcc/fortran/dependency.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 18 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-common.c | 32 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 103 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 14 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dependency_2.f90 | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/logical_dot_product.f90 | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/used_interface_ref.f90 | 48 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 | 26 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 | 23 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 | 54 |
18 files changed, 465 insertions, 18 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d9b2abe..d434281 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2006-03-01 Paul Thomas <pault@gcc.gnu.org> + + * iresolve.c (gfc_resolve_dot_product): Remove any difference in + treatment of logical types. + * trans-intrinsic.c (gfc_conv_intrinsic_dot_product): New function. + + PR fortran/26393 + * trans-decl.c (gfc_get_symbol_decl): Extend condition that symbols + must be referenced to include unreferenced symbols in an interface + body. + + PR fortran/20938 + * trans-array.c (gfc_conv_resolve_dependencies): Add call to + gfc_are_equivalenced_arrays. + * symbol.c (gfc_free_equiv_infos, gfc_free_equiv_lists): New + functions. (gfc_free_namespace): Call them. + * trans-common.c (copy_equiv_list_to_ns): New function. + (add_equivalences): Call it. + * gfortran.h: Add equiv_lists to gfc_namespace and define + gfc_equiv_list and gfc_equiv_info. + * dependency.c (gfc_are_equivalenced_arrays): New function. + (gfc_check_dependency): Call it. + * dependency.h: Prototype for gfc_are_equivalenced_arrays. + 2006-03-01 Roger Sayle <roger@eyesopen.com> * dependency.c (gfc_is_same_range): Compare the stride, lower and diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 96da3c31e4..f764873 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -359,6 +359,51 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent, } +/* Return 1 if e1 and e2 are equivalenced arrays, either + directly or indirectly; ie. equivalence (a,b) for a and b + or equivalence (a,c),(b,c). This function uses the equiv_ + lists, generated in trans-common(add_equivalences), that are + guaranteed to pick up indirect equivalences. A rudimentary + use is made of the offset to ensure that cases where the + source elements are moved down to the destination are not + identified as dependencies. */ + +int +gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) +{ + gfc_equiv_list *l; + gfc_equiv_info *s, *fl1, *fl2; + + gcc_assert (e1->expr_type == EXPR_VARIABLE + && e2->expr_type == EXPR_VARIABLE); + + if (!e1->symtree->n.sym->attr.in_equivalence + || !e2->symtree->n.sym->attr.in_equivalence + || !e1->rank + || !e2->rank) + return 0; + + /* Go through the equiv_lists and return 1 if the variables + e1 and e2 are members of the same group and satisfy the + requirement on their relative offsets. */ + for (l = gfc_current_ns->equiv_lists; l; l = l->next) + { + fl1 = NULL; + fl2 = NULL; + for (s = l->equiv; s; s = s->next) + { + if (s->sym == e1->symtree->n.sym) + fl1 = s; + if (s->sym == e2->symtree->n.sym) + fl2 = s; + if (fl1 && fl2 && (fl1->offset > fl2->offset)) + return 1; + } + } +return 0; +} + + /* Return true if the statement body redefines the condition. Returns true if expr2 depends on expr1. expr1 should be a single term suitable for the lhs of an assignment. The IDENTICAL flag indicates @@ -405,6 +450,10 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical) return 1; } + /* Return 1 if expr1 and expr2 are equivalenced arrays. */ + if (gfc_are_equivalenced_arrays (expr1, expr2)) + return 1; + if (expr1->symtree->n.sym != expr2->symtree->n.sym) return 0; diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index 9862958..3851ca2 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -30,3 +30,4 @@ int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int); int gfc_expr_is_one (gfc_expr *, int); int gfc_dep_resolver(gfc_ref *, gfc_ref *); +int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 17e9777..99b9865 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -950,6 +950,10 @@ typedef struct gfc_namespace /* Points to the equivalences set up in this namespace. */ struct gfc_equiv *equiv; + + /* Points to the equivalence groups produced by trans_common. */ + struct gfc_equiv_list *equiv_lists; + gfc_interface *operator[GFC_INTRINSIC_OPS]; /* Points to the parent namespace, i.e. the namespace of a module or @@ -1343,6 +1347,20 @@ gfc_equiv; #define gfc_get_equiv() gfc_getmem(sizeof(gfc_equiv)) +/* Holds a single equivalence member after processing. */ +typedef struct gfc_equiv_info +{ + gfc_symbol *sym; + HOST_WIDE_INT offset; + struct gfc_equiv_info *next; +} gfc_equiv_info; + +/* Holds equivalence groups, after they have been processed. */ +typedef struct gfc_equiv_list +{ + gfc_equiv_info *equiv; + struct gfc_equiv_list *next; +} gfc_equiv_list; /* gfc_case stores the selector list of a case statement. The *low and *high pointers can point to the same expression in the case of diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index e154a34..f961c77 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -549,21 +549,13 @@ gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b) { gfc_expr temp; - if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) - { - f->ts.type = BT_LOGICAL; - f->ts.kind = gfc_default_logical_kind; - } - else - { - temp.expr_type = EXPR_OP; - gfc_clear_ts (&temp.ts); - temp.value.op.operator = INTRINSIC_NONE; - temp.value.op.op1 = a; - temp.value.op.op2 = b; - gfc_type_convert_binary (&temp); - f->ts = temp.ts; - } + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.operator = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; + gfc_type_convert_binary (&temp); + f->ts = temp.ts; f->value.function.name = gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type), diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 45c7d25..285c276 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2424,6 +2424,31 @@ gfc_free_dt_list (gfc_dt_list * dt) } +/* Free the gfc_equiv_info's. */ + +static void +gfc_free_equiv_infos (gfc_equiv_info * s) +{ + if (s == NULL) + return; + gfc_free_equiv_infos (s->next); + gfc_free (s); +} + + +/* Free the gfc_equiv_lists. */ + +static void +gfc_free_equiv_lists (gfc_equiv_list * l) +{ + if (l == NULL) + return; + gfc_free_equiv_lists (l->next); + gfc_free_equiv_infos (l->equiv); + gfc_free (l); +} + + /* Free a namespace structure and everything below it. Interface lists associated with intrinsic operators are not freed. These are taken care of when a specific name is freed. */ @@ -2459,6 +2484,7 @@ gfc_free_namespace (gfc_namespace * ns) free_st_labels (ns->st_labels); gfc_free_equiv (ns->equiv); + gfc_free_equiv_lists (ns->equiv_lists); gfc_free_dt_list (ns->derived_types); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5e8238b..5e4405e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2581,7 +2581,8 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, if (ss->type != GFC_SS_SECTION) continue; - if (gfc_could_be_alias (dest, ss)) + if (gfc_could_be_alias (dest, ss) + || gfc_are_equivalenced_arrays (dest->expr, ss->expr)) { nDepend = 1; break; diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 5d72a50..3b34b334 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -122,6 +122,7 @@ typedef struct segment_info static segment_info * current_segment; static gfc_namespace *gfc_common_ns = NULL; + /* Make a segment_info based on a symbol. */ static segment_info * @@ -144,6 +145,34 @@ get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) return s; } + +/* Add a copy of a segment list to the namespace. This is specifically for + equivalence segments, so that dependency checking can be done on + equivalence group members. */ + +static void +copy_equiv_list_to_ns (segment_info *c) +{ + segment_info *f; + gfc_equiv_info *s; + gfc_equiv_list *l; + + l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list)); + + l->next = c->sym->ns->equiv_lists; + c->sym->ns->equiv_lists = l; + + for (f = c; f; f = f->next) + { + s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info)); + s->next = l->equiv; + l->equiv = s; + s->sym = f->sym; + s->offset = f->offset; + } +} + + /* Add combine segment V and segment LIST. */ static segment_info * @@ -787,6 +816,9 @@ add_equivalences (bool *saw_equiv) } } } + + /* Add a copy of this segment list to the namespace. */ + copy_equiv_list_to_ns (current_segment); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 65f99c1..47911ff 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -846,7 +846,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) tree length = NULL_TREE; int byref; - gcc_assert (sym->attr.referenced); + gcc_assert (sym->attr.referenced + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY); if (sym->ns && sym->ns->proc_name->attr.function) byref = gfc_return_by_reference (sym->ns->proc_name); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index f58a596..39ac939 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1561,6 +1561,104 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) se->expr = resvar; } + +/* Inline implementation of the dot_product intrinsic. This function + is based on gfc_conv_intrinsic_arith (the previous function). */ +static void +gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss1, *arrayss2; + gfc_se arrayse1, arrayse2; + gfc_expr *arrayexpr1, *arrayexpr2; + + type = gfc_typenode_for_spec (&expr->ts); + + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (expr->ts.type == BT_LOGICAL) + tmp = convert (type, integer_zero_node); + else + tmp = gfc_build_const (type, integer_zero_node); + + gfc_add_modify_expr (&se->pre, resvar, tmp); + + /* Walk argument #1. */ + actual = expr->value.function.actual; + arrayexpr1 = actual->expr; + arrayss1 = gfc_walk_expr (arrayexpr1); + gcc_assert (arrayss1 != gfc_ss_terminator); + + /* Walk argument #2. */ + actual = actual->next; + arrayexpr2 = actual->expr; + arrayss2 = gfc_walk_expr (arrayexpr2); + gcc_assert (arrayss2 != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss1); + gfc_add_ss_to_loop (&loop, arrayss2); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss1, 1); + gfc_mark_ss_chain_used (arrayss2, 1); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + + /* Make the tree expression for [conjg(]array1[)]. */ + gfc_init_se (&arrayse1, NULL); + gfc_copy_loopinfo_to_se (&arrayse1, &loop); + arrayse1.ss = arrayss1; + gfc_conv_expr_val (&arrayse1, arrayexpr1); + if (expr->ts.type == BT_COMPLEX) + arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr); + gfc_add_block_to_block (&block, &arrayse1.pre); + + /* Make the tree expression for array2. */ + gfc_init_se (&arrayse2, NULL); + gfc_copy_loopinfo_to_se (&arrayse2, &loop); + arrayse2.ss = arrayss2; + gfc_conv_expr_val (&arrayse2, arrayexpr2); + gfc_add_block_to_block (&block, &arrayse2.pre); + + /* Do the actual product and sum. */ + if (expr->ts.type == BT_LOGICAL) + { + tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp); + } + else + { + tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (PLUS_EXPR, type, resvar, tmp); + } + gfc_add_modify_expr (&block, resvar, tmp); + + /* Finish up the loop block and the loop. */ + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + + static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) { @@ -3135,6 +3233,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_dim (se, expr); break; + case GFC_ISYM_DOT_PRODUCT: + gfc_conv_intrinsic_dot_product (se, expr); + break; + case GFC_ISYM_DPROD: gfc_conv_intrinsic_dprod (se, expr); break; @@ -3304,7 +3406,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_CHDIR: - case GFC_ISYM_DOT_PRODUCT: case GFC_ISYM_ETIME: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index eb29008..26c178b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2006-03-01 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/logical_dot_product.f90: New test. + + PR fortran/26393 + * gfortran.dg/used_interface_ref.f90: New test. + + PR fortran/20938 + * gfortran.dg/dependency_2.f90: New test. + * gfortran.fortran-torture/execute/where17.f90: New test. + * gfortran.fortran-torture/execute/where18.f90: New test. + * gfortran.fortran-torture/execute/where19.f90: New test. + * gfortran.fortran-torture/execute/where20.f90: New test. + 2006-03-01 Daniel Berlin <dberlin@dberlin.org> * g++.dg/tree-ssa/pr26443.C: New test case. diff --git a/gcc/testsuite/gfortran.dg/dependency_2.f90 b/gcc/testsuite/gfortran.dg/dependency_2.f90 new file mode 100644 index 0000000..1cbdec7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dependency_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Tests the fix for PR20938 in which dependencies between equivalenced +! arrays were not detected. +! +real, dimension (3) :: a = (/1., 2., 3./), b, c +equivalence (a(2), b), (a(1), c) +b = a; +if (any(b .ne. (/1., 2., 3./))) call abort () +b = c +if (any(b .ne. (/1., 1., 2./))) call abort () +end diff --git a/gcc/testsuite/gfortran.dg/logical_dot_product.f90 b/gcc/testsuite/gfortran.dg/logical_dot_product.f90 new file mode 100644 index 0000000..e35595c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/logical_dot_product.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Checks the LOGICAL version of dot_product +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! + logical :: l1(4) = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./) + logical :: l2(4) = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./) + if (dot_product (l1, l2)) call abort () + l2 = .TRUE. + if (.not.dot_product (l1, l2)) call abort () +end
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/used_interface_ref.f90 b/gcc/testsuite/gfortran.dg/used_interface_ref.f90 new file mode 100644 index 0000000..d4a9c96 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_interface_ref.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Tests the fix for PR26393, in which an ICE would occur in trans-decl.c +! (gfc_get_symbol_decl) because anzKomponenten is not referenced in the +! interface for solveCConvert. The solution was to assert that the symbol +! is either referenced or in an interface body. +! +! Based on the testcase in the PR. +! + MODULE MODULE_CONC + INTEGER, SAVE :: anzKomponenten = 2 + END MODULE MODULE_CONC + + MODULE MODULE_THERMOCALC + INTERFACE + FUNCTION solveCConvert () + USE MODULE_CONC, ONLY: anzKomponenten + REAL :: solveCConvert(1:anzKomponenten) + END FUNCTION solveCConvert + END INTERFACE + END MODULE MODULE_THERMOCALC + + SUBROUTINE outDiffKoeff + USE MODULE_CONC + USE MODULE_THERMOCALC + REAL :: buffer_conc(1:anzKomponenten) + buffer_conc = solveCConvert () + if (any(buffer_conc .ne. (/(real(i), i = 1, anzKomponenten)/))) & + call abort () + END SUBROUTINE outDiffKoeff + + program missing_ref + USE MODULE_CONC + call outDiffKoeff +! Now set anzKomponenten to a value that would cause a segfault if +! buffer_conc and solveCConvert did not have the correct allocation +! of memory. + anzKomponenten = 5000 + call outDiffKoeff + end program missing_ref + + FUNCTION solveCConvert () + USE MODULE_CONC, ONLY: anzKomponenten + REAL :: solveCConvert(1:anzKomponenten) + solveCConvert = (/(real(i), i = 1, anzKomponenten)/) + END FUNCTION solveCConvert + + + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 new file mode 100644 index 0000000..b4323ca --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 @@ -0,0 +1,15 @@ +! Check to ensure only the first true clause in WHERE is +! executed. +program where_17 + integer :: a(3) + + a = (/1, 2, 3/) + where (a .eq. 1) + a = 2 + elsewhere (a .le. 2) + a = 3 + elsewhere (a .le. 3) + a = 4 + endwhere + if (any (a .ne. (/2, 3, 4/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 new file mode 100644 index 0000000..4036464 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 @@ -0,0 +1,26 @@ +! Check to ensure mask is calculated first in WHERE +! statements. +program where_18 + integer :: a(4) + integer :: b(3) + integer :: c(3) + equivalence (a(1), b(1)), (a(2), c(1)) + + a = (/1, 1, 1, 1/) + where (b .eq. 1) + c = 2 + elsewhere (b .eq. 2) + c = 3 + endwhere + if (any (a .ne. (/1, 2, 2, 2/))) & + call abort + + a = (/1, 1, 1, 1/) + where (c .eq. 1) + b = 2 + elsewhere (b .eq. 2) + b = 3 + endwhere + if (any (a .ne. (/2, 2, 2, 1/))) & + call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 new file mode 100644 index 0000000..3c41b89 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 @@ -0,0 +1,23 @@ +! Check to ensure result is calculated from unmodified +! version of the right-hand-side in WHERE statements. +program where_19 + integer :: a(4) + integer :: b(3) + integer :: c(3) + equivalence (a(1), b(1)), (a(2), c(1)) + + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = b + endwhere + if (any (a .ne. (/1, 2, 2, 3/))) & + call abort () + + a = (/1, 2, 3, 4/) + where (c .gt. 1) + b = c + endwhere + if (any (a .ne. (/2, 3, 4, 4/))) & + call abort () +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 new file mode 100644 index 0000000..b045650 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 @@ -0,0 +1,54 @@ +! Test the dependency checking in simple where. This +! did not work and was fixed as part of the patch for +! pr24519. +! +program where_20 + integer :: a(4) + integer :: b(3) + integer :: c(3) + integer :: d(3) = (/1, 2, 3/) + equivalence (a(1), b(1)), (a(2), c(1)) + +! This classic case worked before the patch. + a = (/1, 2, 3, 4/) + where (b .gt. 1) a(2:4) = a(1:3) + if (any(a .ne. (/1,2,2,3/))) call abort () + +! This is the original manifestation of the problem +! and is repeated in where_19.f90. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = b + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Mask to.destination dependency. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = d + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Source to.destination dependency. + a = (/1, 2, 3, 4/) + where (d .gt. 1) + c = b + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Check the simple where. + a = (/1, 2, 3, 4/) + where (b .gt. 1) c = b + if (any(a .ne. (/1,2,2,3/))) call abort () + +! This was OK before the patch. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + where (d .gt. 1) + c = b + end where + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +end program + |