From 8a49b30e2dec1c93ba8101a8e198175275de4ac9 Mon Sep 17 00:00:00 2001 From: tobi Date: Sat, 6 Oct 2007 08:55:30 +0000 Subject: [PATCH] PR fortran/25076 fortran/ * resolve.c (gfc_find_forall_index): Move towards top, renaming to ... (find_forall_index): ... this. Add check for NULL expr. (resolve_forall_iterators): Verify additional constraint. (resolve_forall): Remove checks obsoleted by new code in resolve_forall_iterators. testsuite/ * gfortran.dg/forall_11.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@129050 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 ++ gcc/fortran/resolve.c | 294 ++++++++++++++++---------------- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/forall_11.f90 | 33 ++++ 4 files changed, 199 insertions(+), 143 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/forall_11.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 834a5b947fa..9093bed87ac 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2007-10-06 Tobias Schlüter + + PR fortran/25076 + * resolve.c (gfc_find_forall_index): Move towards top, + renaming to ... + (find_forall_index): ... this. Add check for NULL expr. + (resolve_forall_iterators): Verify additional constraint. + (resolve_forall): Remove checks obsoleted by new code in + resolve_forall_iterators. + 2007-10-05 Francois-Xavier Coudert * gfortran.h (gfc_get_data_variable, gfc_get_data_value, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 452a8d837eb..50164f66949 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4296,14 +4296,147 @@ 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. */ + +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; +} + + /* Resolve a list of FORALL iterators. The FORALL index-name is constrained to be a scalar INTEGER variable. The subscripts and stride are scalar - INTEGERs, and if stride is a constant it must be nonzero. */ + INTEGERs, and if stride is a constant it must be nonzero. + Furthermore "A subscript or stride in a forall-triplet-spec shall + not contain a reference to any index-name in the + forall-triplet-spec-list in which it appears." (7.5.4.1) */ static void -resolve_forall_iterators (gfc_forall_iterator *iter) +resolve_forall_iterators (gfc_forall_iterator *it) { - while (iter) + gfc_forall_iterator *iter, *iter2; + + for (iter = it; iter; iter = iter->next) { if (gfc_resolve_expr (iter->var) == SUCCESS && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) @@ -4337,9 +4470,21 @@ resolve_forall_iterators (gfc_forall_iterator *iter) } if (iter->var->ts.kind != iter->stride->ts.kind) gfc_convert_type (iter->stride, &iter->var->ts, 2); - - iter = iter->next; } + + for (iter = it; iter; iter = iter->next) + 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); + } } @@ -5529,130 +5674,6 @@ resolve_where (gfc_code *code, gfc_expr *mask) } -/* Check whether the FORALL index appears in the expression or not. */ - -static try -gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) -{ - gfc_array_ref ar; - gfc_ref *tmp; - gfc_actual_arglist *args; - int i; - - 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 (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS) - return SUCCESS; - - if (ar.end[i]) - if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS) - return SUCCESS; - - if (ar.stride[i]) - if (gfc_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 (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS) - return SUCCESS; - if (gfc_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 (gfc_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 (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS) - return SUCCESS; - if (gfc_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 (gfc_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 (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS) - return SUCCESS; - } - break; - - default: - break; - } - - return FAILURE; -} - - /* Resolve assignment in FORALL construct. NVAR is the number of FORALL index variables, and VAR_EXPR records the FORALL index variables. */ @@ -5679,7 +5700,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 (gfc_find_forall_index (code->expr, forall_index) == FAILURE) + 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); @@ -5785,7 +5806,6 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static int total_var = 0; static int nvar = 0; gfc_forall_iterator *fa; - gfc_symbol *forall_index; gfc_code *next; int i; @@ -5824,18 +5844,6 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) /* Record the current FORALL index. */ var_expr[nvar] = gfc_copy_expr (fa->var); - forall_index = fa->var->symtree->n.sym; - - /* Check if the FORALL index appears in start, end or stride. */ - if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS) - gfc_error ("A FORALL index must not appear in a limit or stride " - "expression in the same FORALL at %L", &fa->start->where); - if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS) - gfc_error ("A FORALL index must not appear in a limit or stride " - "expression in the same FORALL at %L", &fa->end->where); - if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS) - gfc_error ("A FORALL index must not appear in a limit or stride " - "expression in the same FORALL at %L", &fa->stride->where); nvar++; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b9d2e75c51f..bb6a5886348 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-10-06 Tobias Schlüter + + PR fortran/25076 + * gfortran.dg/forall_11.f90: New. + 2007-10-05 Michael Matz PR middle-end/33667 diff --git a/gcc/testsuite/gfortran.dg/forall_11.f90 b/gcc/testsuite/gfortran.dg/forall_11.f90 new file mode 100644 index 00000000000..4c556951c7e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/forall_11.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR 25076 +! We erroneously accepted it when a FORALL index was used in a triplet +! specification within the same FORALL header +INTEGER :: A(10,10) +FORALL(I=1:10,J=I:10) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + A(I,J)=I+J +ENDFORALL + +forall (i=1:10, j=1:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(i,j) = 5 +end forall + +forall (i=1:10, j=1:10:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(i,j) = i - j +end forall + +forall (i=i:10) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + forall (j=1:j:i) ! { dg-error "FORALL index 'j' may not appear in triplet specification" } + a(i,j) = i*j + end forall +end forall + +forall (i=1:10:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(1,i) = 2 +end forall + +forall (i=1:10) + forall (j=i:10) + a(i,j) = i*j + end forall +end forall +END -- 2.11.0