[Bug fortran/96255] [F2018] Implement optional type spec for index in DO CONCURRENT

["kargl at gcc dot gnu.org" <gcc-bugzilla@gcc.gnu.org>]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=96255

--- Comment #8 from kargl at gcc dot gnu.org ---
New patch.  This adds a bool component to gfc_forall_iterator so
that an iterator with an index-name that shadows a variable from
outer scope can be marked.  Shadowing only occurs when a type-spec
causes the kind type parameter to differ from the kind type 
parameter of the outer scope variable.

A fatal error occurs if shadowing is found.  Someone needs to
wlak the forall block (and by extension the do concurrent block)
updating references to the outer scope variable to be those of
the shadow variable.

It might be beneficial to introduce a namespace for forall and
do concurrent, but I won't go down that path.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h      (revision 280157)
+++ gcc/fortran/gfortran.h      (working copy)
@@ -2525,6 +2525,8 @@ gfc_dt;
 typedef struct gfc_forall_iterator
 {
   gfc_expr *var, *start, *end, *stride;
+  /* index-name shadows a variable from outer scope.  */
+  bool shadow;
   struct gfc_forall_iterator *next;
 }
 gfc_forall_iterator;
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 280157)
+++ gcc/fortran/match.c (working copy)
@@ -2381,7 +2381,10 @@ cleanup:
 }


-/* Match the header of a FORALL statement.  */
+/* Match the header of a FORALL statement.  In F2008 and F2018, the form of
+   the header is 
+   ([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] )
+   where type-spec is INTEGER.  */

 static match
 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
@@ -2389,6 +2392,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_
   gfc_forall_iterator *head, *tail, *new_iter;
   gfc_expr *msk;
   match m;
+  gfc_typespec ts;
+  bool seen_ts = false;
+  locus loc;

   gfc_gobble_whitespace ();

@@ -2398,12 +2404,76 @@ match_forall_header (gfc_forall_iterator **phead, gfc_
   if (gfc_match_char ('(') != MATCH_YES)
     return MATCH_NO;

+  /* Check for an optional type-spec.  */
+  gfc_clear_ts (&ts);
+  loc = gfc_current_locus;
+  m = gfc_match_type_spec (&ts);
+  if (m == MATCH_YES)
+    {
+      seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+      if (seen_ts)
+       {
+         if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT "
+                              "construct includes type specification "
+                              "at %L", &loc))
+           goto cleanup;
+
+         if (ts.type != BT_INTEGER)
+           {
+             gfc_error ("Type-spec at %L must be an INTEGER type", &loc);
+             goto cleanup;
+           }
+       }
+    }
+  else if (m == MATCH_ERROR)
+    goto syntax;
+
   m = match_forall_iterator (&new_iter);
   if (m == MATCH_ERROR)
     goto cleanup;
   if (m == MATCH_NO)
     goto syntax;

+  if (seen_ts)
+    {
+      char *name;
+      gfc_expr *v;
+      gfc_symtree *st;
+
+      /* If index-name does not have a type and type spec, then update the
+        type spec in both the expr and symtree.  Otherwise, create a new
+        shadow index-name.  */
+      new_iter->shadow = false;
+      v = new_iter->var;
+      if (v->ts.type == BT_UNKNOWN)
+       {
+         v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER;
+         v->ts.kind = v->symtree->n.sym->ts.kind = ts.kind;
+       }
+      else if (v->ts.kind != ts.kind)
+       {
+         name = (char *) alloca (strlen (v->symtree->name) + 2);
+         strcpy (name, "_");
+         strcat (name, v->symtree->name);
+         if (gfc_get_sym_tree (name, NULL, &st, false) != 0)
+           gfc_internal_error ("whoops");
+
+         v = gfc_get_expr ();
+         v->where = gfc_current_locus;
+         v->expr_type = EXPR_VARIABLE;
+         v->ts.type = st->n.sym->ts.type = ts.type;
+         v->ts.kind = st->n.sym->ts.kind = ts.kind;
+         st->n.sym->forall_index = true;
+         v->symtree = st;
+         gfc_replace_expr (new_iter->var, v);
+         new_iter->shadow = true;
+       }
+      gfc_convert_type (new_iter->start, &ts, 1);
+      gfc_convert_type (new_iter->end, &ts, 1);
+      gfc_convert_type (new_iter->stride, &ts, 1);
+    }
+
   head = tail = new_iter;

   for (;;)
@@ -2417,6 +2487,44 @@ match_forall_header (gfc_forall_iterator **phead, gfc_

       if (m == MATCH_YES)
        {
+         if (seen_ts)
+           {
+             char *name;
+             gfc_expr *v;
+             gfc_symtree *st;
+
+             new_iter->shadow = false;
+             v = new_iter->var;
+             if (v->ts.type == BT_UNKNOWN)
+               {
+                 v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER;
+                 v->ts.kind = v->symtree->n.sym->ts.kind = ts.kind;
+               }
+             else if (v->ts.kind != ts.kind)
+               {
+                 name = (char *) alloca (strlen (v->symtree->name) + 2);
+                 strcpy (name, "_");
+                 strcat (name, v->symtree->name);
+                 if (gfc_get_sym_tree (name, NULL, &st, false) != 0)
+                   gfc_internal_error ("whoops");
+
+                 v = gfc_get_expr ();
+                 v->expr_type = EXPR_VARIABLE;
+                 v->ts.type = ts.type;
+                 v->ts.kind = ts.kind;
+                 v->where = gfc_current_locus;
+                 st->n.sym->ts.type = ts.type;
+                 st->n.sym->ts.kind = ts.kind;
+                 st->n.sym->forall_index = true;
+                 v->symtree = st;
+                 gfc_replace_expr (new_iter->var, v);
+                 new_iter->shadow = true;
+               }
+             gfc_convert_type (new_iter->start, &ts, 1);
+             gfc_convert_type (new_iter->end, &ts, 1);
+             gfc_convert_type (new_iter->stride, &ts, 1);
+           }
+
          tail->next = new_iter;
          tail = new_iter;
          continue;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c       (revision 280157)
+++ gcc/fortran/resolve.c       (working copy)
@@ -10322,11 +10322,10 @@ static void
 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
 {
   int n;
+  gfc_symbol *forall_index;

   for (n = 0; n < nvar; n++)
     {
-      gfc_symbol *forall_index;
-
       forall_index = var_expr[n]->symtree->n.sym;

       /* Check whether the assignment target is one of the FORALL index
@@ -10475,8 +10474,10 @@ gfc_count_forall_iterators (gfc_code *code)
 }


-/* Given a FORALL construct, first resolve the FORALL iterator, then call
-   gfc_resolve_forall_body to resolve the FORALL body.  */
+/* Given a FORALL construct.
+   1) Resolve the FORALL iterator.
+   2) Check for shadow index-name(s) and update code block.
+   3) call gfc_resolve_forall_body to resolve the FORALL body.  */

 static void
 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
@@ -10486,6 +10487,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns,
   static int nvar = 0;
   int i, old_nvar, tmp;
   gfc_forall_iterator *fa;
+  bool shadow = false;

   old_nvar = nvar;

@@ -10503,8 +10505,9 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns,
       var_expr = XCNEWVEC (gfc_expr *, total_var);
     }

-  /* The information about FORALL iterator, including FORALL indices start,
end
-     and stride.  An outer FORALL indice cannot appear in start, end or
stride.  */
+  /* The information about FORALL iterator, including FORALL indices start,
+     end and stride.  An outer FORALL indice cannot appear in start, end or
+     stride.  Check for a shadow index-name.  */
   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
     {
       /* Fortran 20008: C738 (R753).  */
@@ -10524,6 +10527,9 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns,
                        "with this name %L", &fa->var->where);
        }

+      if (fa->shadow)
+       shadow = true;
+
       /* Record the current FORALL index.  */
       var_expr[nvar] = gfc_copy_expr (fa->var);

@@ -10532,6 +10538,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns,
       /* No memory leak.  */
       gcc_assert (nvar <= total_var);
     }
+
+  /* Need to walk the code and replace references to the index-name with
+     references to the shadow index-name.  */
+  if (shadow)
+    gfc_fatal_error ("An index-name shadows a variable from outer scope, "
+                    "which causes a wrong-code bug.");

   /* Resolve the FORALL body.  */
   gfc_resolve_forall_body (code, nvar, var_expr);