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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 834a5b9..9093bed 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2007-10-06  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+       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  <fxcoudert@gcc.gnu.org>
 
        * gfortran.h (gfc_get_data_variable, gfc_get_data_value,

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 452a8d8..50164f6 100644 (file)
--- 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 b9d2e75..bb6a588 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-10-06  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+       PR fortran/25076
+       * gfortran.dg/forall_11.f90: New.
+
 2007-10-05  Michael Matz  <matz@suse.de>
 
        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 (file)
index 0000000..4c55695
--- /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