https://gcc.gnu.org/g:5e62a23cc3a64fa0312ffa414fcd1aaba18baa02

commit r16-5177-g5e62a23cc3a64fa0312ffa414fcd1aaba18baa02
Author: Jerry DeLisle <[email protected]>
Date:   Tue Nov 11 10:47:31 2025 -0800

    fortran: Implement optional type spec for DO CONCURRENT [PR96255]
    
    This patch adds support for the F2008 optional integer type specification
    in DO CONCURRENT and FORALL headers, allowing constructs like:
    
      do concurrent (integer :: i=1:10)
    
    The implementation handles type spec matching, creates shadow variables
    when the type spec differs from any outer scope variable, and converts
    iterator expressions to match the specified type.
    
    Shadow variable implementation:
    When a type-spec is provided and differs from an outer scope variable,
    a shadow variable with the specified type is created (with _ prefix).
    A recursive expression walker substitutes all references to the outer
    variable with the shadow variable throughout the DO CONCURRENT body,
    including in array subscripts, substrings, and nested operations.
    
    Constraint enforcement:
    Sets gfc_do_concurrent_flag properly (1 for block context, 2 for mask
    context) to enable F2008 C1139 enforcement, ensuring only PURE procedures
    are allowed in DO CONCURRENT constructs.
    
    Additional fixes:
    - Extract apply_typespec_to_iterator() helper to eliminate duplicated
      shadow variable creation code (~70 lines)
    - Add NULL pointer checks for shadow variables
    - Fix iterator counting to handle both EXEC_FORALL and EXEC_DO_CONCURRENT
    - Skip FORALL obsolescence warning for DO CONCURRENT (F2018)
    - Suppress many-to-one assignment warning for DO CONCURRENT (reductions
      are valid, formalized with REDUCE locality-spec in F2023)
    
            PR fortran/96255
    
    gcc/fortran/ChangeLog:
    
            * gfortran.h (gfc_forall_iterator): Add bool shadow field.
            * match.cc (apply_typespec_to_iterator): New helper function to
            consolidate shadow variable creation logic.
            (match_forall_header): Add type-spec parsing for DO CONCURRENT
            and FORALL. Create shadow variables when type-spec differs from
            outer scope. Replace duplicated code with 
apply_typespec_to_iterator.
            * resolve.cc (replace_in_expr_recursive): New function to 
recursively
            walk expressions and replace symbol references.
            (replace_in_code_recursive): New function to recursively walk code
            blocks and replace symbol references.
            (gfc_replace_forall_variable): New entry point for shadow variable
            substitution.
            (gfc_resolve_assign_in_forall): Skip many-to-one assignment warning
            for DO CONCURRENT.
            (gfc_count_forall_iterators): Handle both EXEC_FORALL and
            EXEC_DO_CONCURRENT with assertion.
            (gfc_resolve_forall): Skip F2018 obsolescence warning for DO
            CONCURRENT. Fix memory allocation check. Add NULL checks for shadow
            variables. Implement shadow variable walker.
            (gfc_resolve_code): Set gfc_do_concurrent_flag for DO CONCURRENT
            constructs to enable constraint checking.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/do_concurrent_typespec_1.f90: New test covering all
            shadowing scenarios: undeclared variable, same kind shadowing, and
            different kind shadowing.
    
    Co-authored-by: Steve Kargl <[email protected]>
    Co-authored-by: Jerry DeLisle <[email protected]>
    Signed-off-by: Christopher Albert <[email protected]>

Diff:
---
 gcc/fortran/gfortran.h                             |   2 +
 gcc/fortran/match.cc                               |  93 +++++++-
 gcc/fortran/resolve.cc                             | 254 +++++++++++++++++++--
 .../gfortran.dg/do_concurrent_typespec_1.f90       | 113 +++++++++
 4 files changed, 442 insertions(+), 20 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f1c4db23d00c..848ad9ca1fa2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3101,6 +3101,8 @@ typedef struct gfc_forall_iterator
 {
   gfc_expr *var, *start, *end, *stride;
   gfc_loop_annot annot;
+  /* index-name shadows a variable from outer scope.  */
+  bool shadow;
   struct gfc_forall_iterator *next;
 }
 gfc_forall_iterator;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 8355a390ee08..60434c14ee27 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2608,7 +2608,64 @@ cleanup:
 }
 
 
-/* Match the header of a FORALL statement.  */
+/* Apply type-spec to iterator and create shadow variable if needed.  */
+
+static void
+apply_typespec_to_iterator (gfc_forall_iterator *iter, gfc_typespec *ts,
+                            locus *loc)
+{
+  char *name;
+  gfc_expr *v;
+  gfc_symtree *st;
+
+  /* When a type-spec is provided in DO CONCURRENT/FORALL, F2018 19.4(6)
+     requires the index-name to have scope limited to the construct,
+     shadowing any variable with the same name from outer scope.
+     If the index-name was not previously declared, we can simply set its
+     type.  Otherwise, create a shadow variable with "_" prefix.  */
+  iter->shadow = false;
+  v = iter->var;
+  if (v->ts.type == BT_UNKNOWN)
+    {
+      /* Variable not declared in outer scope - just set the type.  */
+      v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER;
+      v->ts.kind = v->symtree->n.sym->ts.kind = ts->kind;
+    }
+  else
+    {
+      /* Variable exists in outer scope - must create shadow to comply
+        with F2018 19.4(6) scoping rules.  */
+      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 ("Failed to create shadow variable symtree for "
+                           "DO CONCURRENT type-spec at %L", loc);
+
+      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 (iter->var, v);
+      iter->shadow = true;
+    }
+
+  /* Convert iterator bounds to the specified type.  */
+  gfc_convert_type (iter->start, ts, 1);
+  gfc_convert_type (iter->end, ts, 1);
+  gfc_convert_type (iter->stride, ts, 1);
+}
+
+
+/* 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)
@@ -2616,6 +2673,9 @@ match_forall_header (gfc_forall_iterator **phead, 
gfc_expr **mask)
   gfc_forall_iterator *head, *tail, *new_iter;
   gfc_expr *msk;
   match m;
+  gfc_typespec ts;
+  bool seen_ts = false;
+  locus loc;
 
   gfc_gobble_whitespace ();
 
@@ -2625,12 +2685,40 @@ match_forall_header (gfc_forall_iterator **phead, 
gfc_expr **mask)
   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)
+    apply_typespec_to_iterator (new_iter, &ts, &loc);
+
   head = tail = new_iter;
 
   for (;;)
@@ -2644,6 +2732,9 @@ match_forall_header (gfc_forall_iterator **phead, 
gfc_expr **mask)
 
       if (m == MATCH_YES)
        {
+         if (seen_ts)
+           apply_typespec_to_iterator (new_iter, &ts, &loc);
+
          tail->next = new_iter;
          tail = new_iter;
          continue;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 2a73f2a7ab55..aad211a30eca 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6151,7 +6151,7 @@ gfc_resolve_ref (gfc_expr *expr)
            }
 
          /* The F08 standard requires(See R425, R431, R435, and in particular
-            Note 6.7) that a PDT parameter reference be a scalar even if 
+            Note 6.7) that a PDT parameter reference be a scalar even if
             the designator is an array."  */
          if (array_ref && last_pdt && last_pdt->attr.pdt_type
              && (ref->u.c.component->attr.pdt_kind
@@ -12251,11 +12251,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
@@ -12269,8 +12268,12 @@ 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 variable, then there could be a many-to-one
             assignment.  Emit a warning rather than an error because the
-            mask could be resolving this problem.  */
-         if (!find_forall_index (code->expr1, forall_index, 0))
+            mask could be resolving this problem.
+            DO NOT emit this warning for DO CONCURRENT - reduction-like
+            many-to-one assignments are semantically valid (formalized with
+            the REDUCE locality-spec in Fortran 2023).  */
+         if (!find_forall_index (code->expr1, forall_index, 0)
+             && !gfc_do_concurrent_flag)
            gfc_warning (0, "The FORALL with index %qs is not used on the "
                         "left side of the assignment at %L and so might "
                         "cause multiple assignment to this object",
@@ -12390,7 +12393,7 @@ gfc_count_forall_iterators (gfc_code *code)
   int max_iters, sub_iters, current_iters;
   gfc_forall_iterator *fa;
 
-  gcc_assert(code->op == EXEC_FORALL);
+  gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT);
   max_iters = 0;
   current_iters = 0;
 
@@ -12401,7 +12404,7 @@ gfc_count_forall_iterators (gfc_code *code)
 
   while (code)
     {
-      if (code->op == EXEC_FORALL)
+      if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
         {
           sub_iters = gfc_count_forall_iterators (code);
           if (sub_iters > max_iters)
@@ -12414,8 +12417,160 @@ 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.  */
+
+/* Custom recursive expression walker that replaces symbols.
+   This ensures we visit ALL expressions including those in array subscripts.  
*/
+
+static void
+replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree 
*new_st)
+{
+  if (!expr)
+    return;
+
+  /* Check if this is a variable reference to replace */
+  if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym)
+    {
+      expr->symtree = new_st;
+      expr->ts = new_st->n.sym->ts;
+    }
+
+  /* Walk through reference chain (array subscripts, substrings, etc.) */
+  for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+       {
+         gfc_array_ref *ar = &ref->u.ar;
+         for (int i = 0; i < ar->dimen; i++)
+           {
+             replace_in_expr_recursive (ar->start[i], old_sym, new_st);
+             replace_in_expr_recursive (ar->end[i], old_sym, new_st);
+             replace_in_expr_recursive (ar->stride[i], old_sym, new_st);
+           }
+       }
+      else if (ref->type == REF_SUBSTRING)
+       {
+         replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st);
+         replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st);
+       }
+    }
+
+  /* Walk through sub-expressions based on expression type */
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st);
+      replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st);
+      break;
+
+    case EXPR_FUNCTION:
+      for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
+       replace_in_expr_recursive (a->expr, old_sym, new_st);
+      break;
+
+    case EXPR_ARRAY:
+    case EXPR_STRUCTURE:
+      for (gfc_constructor *c = gfc_constructor_first 
(expr->value.constructor);
+          c; c = gfc_constructor_next (c))
+       {
+         replace_in_expr_recursive (c->expr, old_sym, new_st);
+         if (c->iterator)
+           {
+             replace_in_expr_recursive (c->iterator->start, old_sym, new_st);
+             replace_in_expr_recursive (c->iterator->end, old_sym, new_st);
+             replace_in_expr_recursive (c->iterator->step, old_sym, new_st);
+           }
+       }
+      break;
+
+    default:
+      break;
+    }
+}
+
+
+/* Walk code tree and replace all variable references */
+
+static void
+replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree 
*new_st)
+{
+  if (!code)
+    return;
+
+  for (gfc_code *c = code; c; c = c->next)
+    {
+      /* Replace in expressions associated with this code node */
+      replace_in_expr_recursive (c->expr1, old_sym, new_st);
+      replace_in_expr_recursive (c->expr2, old_sym, new_st);
+      replace_in_expr_recursive (c->expr3, old_sym, new_st);
+      replace_in_expr_recursive (c->expr4, old_sym, new_st);
+
+      /* Handle special code types with additional expressions */
+      switch (c->op)
+       {
+       case EXEC_DO:
+         if (c->ext.iterator)
+           {
+             replace_in_expr_recursive (c->ext.iterator->start, old_sym, 
new_st);
+             replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st);
+             replace_in_expr_recursive (c->ext.iterator->step, old_sym, 
new_st);
+           }
+         break;
+
+       case EXEC_CALL:
+       case EXEC_ASSIGN_CALL:
+         for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next)
+           replace_in_expr_recursive (a->expr, old_sym, new_st);
+         break;
+
+       case EXEC_SELECT:
+         for (gfc_code *b = c->block; b; b = b->block)
+           {
+             for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next)
+               {
+                 replace_in_expr_recursive (cp->low, old_sym, new_st);
+                 replace_in_expr_recursive (cp->high, old_sym, new_st);
+               }
+             replace_in_code_recursive (b->next, old_sym, new_st);
+           }
+         break;
+
+       case EXEC_FORALL:
+       case EXEC_DO_CONCURRENT:
+         for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa 
= fa->next)
+           {
+             replace_in_expr_recursive (fa->start, old_sym, new_st);
+             replace_in_expr_recursive (fa->end, old_sym, new_st);
+             replace_in_expr_recursive (fa->stride, old_sym, new_st);
+           }
+         /* Don't recurse into nested FORALL/DO CONCURRENT bodies here,
+            they'll be handled separately */
+         break;
+
+       default:
+         break;
+       }
+
+      /* Recurse into blocks */
+      if (c->block)
+       replace_in_code_recursive (c->block->next, old_sym, new_st);
+    }
+}
+
+
+/* Replace all references to outer_sym with shadow_st in the given code.  */
+
+static void
+gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym,
+                             gfc_symtree *shadow_st)
+{
+  /* Use custom recursive walker to ensure we visit ALL expressions */
+  replace_in_code_recursive (*code_ptr, outer_sym, shadow_st);
+}
+
 
 static void
 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
@@ -12425,14 +12580,21 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace 
*ns, int forall_save)
   static int nvar = 0;
   int i, old_nvar, tmp;
   gfc_forall_iterator *fa;
+  bool shadow = false;
 
   old_nvar = nvar;
 
-  if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", 
&code->loc))
+  /* Only warn about obsolescent FORALL, not DO CONCURRENT */
+  if (code->op == EXEC_FORALL
+      && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", 
&code->loc))
     return;
 
   /* Start to resolve a FORALL construct   */
-  if (forall_save == 0)
+  /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level.
+     forall_save==0 means we're not nested in a FORALL in the current scope,
+     but nvar==0 ensures we're not nested in a parent scope either (prevents
+     double allocation when FORALL is nested inside DO CONCURRENT).  */
+  if (forall_save == 0 && nvar == 0)
     {
       /* Count the total number of FORALL indices in the nested FORALL
          construct in order to allocate the VAR_EXPR with proper size.  */
@@ -12442,11 +12604,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace 
*ns, int forall_save)
       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.concur.forall_iterator; fa; fa = fa->next)
     {
-      /* Fortran 20008: C738 (R753).  */
+      /* Fortran 2008: C738 (R753).  */
       if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
        {
          gfc_error ("FORALL index-name at %L must be a scalar variable "
@@ -12455,14 +12618,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace 
*ns, int forall_save)
        }
 
       /* Check if any outer FORALL index name is the same as the current
-        one.  */
+        one.  Skip this check if the iterator is a shadow variable (from
+        DO CONCURRENT type spec) which may not have a symtree yet.  */
       for (i = 0; i < nvar; i++)
        {
-         if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
+         if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree
+             && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
            gfc_error ("An outer FORALL construct already has an index "
                        "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);
 
@@ -12472,6 +12640,48 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, 
int forall_save)
       gcc_assert (nvar <= total_var);
     }
 
+  /* Need to walk the code and replace references to the index-name with
+     references to the shadow index-name. This must be done BEFORE resolving
+     the body so that resolution uses the correct shadow variables.  */
+  if (shadow)
+    {
+      /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed 
variables.  */
+      for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
+       {
+         if (fa->shadow)
+           {
+             gfc_symbol *outer_sym;
+             gfc_symtree *shadow_st;
+             const char *shadow_name_str;
+             char *outer_name;
+
+             /* fa->var now points to the shadow variable "_name".  */
+             shadow_name_str = fa->var->symtree->name;
+             shadow_st = fa->var->symtree;
+
+             if (shadow_name_str[0] != '_')
+               gfc_internal_error ("Expected shadow variable name to start 
with _");
+
+             outer_name = (char *) alloca (strlen (shadow_name_str));
+             strcpy (outer_name, shadow_name_str + 1);
+
+             /* Find the ITERATOR symbol in the current namespace.
+                This is the local DO CONCURRENT variable that body expressions 
reference.  */
+             gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, 
outer_name);
+
+             if (!iter_st)
+               /* No iterator variable found - this shouldn't happen */
+               continue;
+
+             gfc_symbol *iter_sym = iter_st->n.sym;
+
+             /* Walk the FORALL/DO CONCURRENT body and replace all references. 
 */
+             if (code->block && code->block->next)
+               gfc_replace_forall_variable (&code->block->next, iter_sym, 
shadow_st);
+           }
+       }
+    }
+
   /* Resolve the FORALL body.  */
   gfc_resolve_forall_body (code, nvar, var_expr);
 
@@ -13741,11 +13951,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
       forall_save = forall_flag;
       do_concurrent_save = gfc_do_concurrent_flag;
 
-      if (code->op == EXEC_FORALL)
+      if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT)
        {
-         forall_flag = 1;
+         if (code->op == EXEC_FORALL)
+           forall_flag = 1;
+         else if (code->op == EXEC_DO_CONCURRENT)
+           gfc_do_concurrent_flag = 1;
          gfc_resolve_forall (code, ns, forall_save);
-         forall_flag = 2;
+         if (code->op == EXEC_FORALL)
+           forall_flag = 2;
+         else if (code->op == EXEC_DO_CONCURRENT)
+           gfc_do_concurrent_flag = 2;
        }
       else if (code->op == EXEC_OMP_METADIRECTIVE)
        for (gfc_omp_variant *variant
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_typespec_1.f90 
b/gcc/testsuite/gfortran.dg/do_concurrent_typespec_1.f90
new file mode 100644
index 000000000000..f5c498f6f278
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_typespec_1.f90
@@ -0,0 +1,113 @@
+! { dg-do run }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/96255
+! Test DO CONCURRENT with optional type specification
+! Covers all shadowing scenarios per F2018 19.4(6)
+
+program test_do_concurrent_typespec
+  implicit none
+  integer :: test_count
+  test_count = 0
+
+  ! Test 1: Type-spec with no outer scope variable (BT_UNKNOWN)
+  ! Should just set the type, no shadow needed
+  call test_no_outer_var()
+  test_count = test_count + 1
+
+  ! Test 2: Type-spec shadows outer variable with same kind
+  ! Must create shadow per F2018 19.4(6)
+  call test_shadow_same_kind()
+  test_count = test_count + 1
+
+  ! Test 3: Type-spec shadows outer variable with different kind
+  ! Must create shadow per F2018 19.4(6)
+  call test_shadow_different_kind()
+  test_count = test_count + 1
+
+  ! Test 4: Multiple iterators with mixed scenarios
+  call test_multiple_iterators()
+  test_count = test_count + 1
+
+  print *, "All", test_count, "tests passed"
+
+contains
+
+  subroutine test_no_outer_var()
+    implicit none
+    integer :: sum_val
+
+    ! 'j' is not declared in outer scope
+    sum_val = 0
+    do concurrent (integer :: j = 1:5)
+      sum_val = sum_val + j
+    end do
+
+    if (sum_val /= 15) stop 1  ! 1+2+3+4+5 = 15
+  end subroutine test_no_outer_var
+
+  subroutine test_shadow_same_kind()
+    implicit none
+    integer :: i
+    integer :: outer_val, inner_sum
+
+    ! Set outer 'i' to a specific value
+    i = 99
+    outer_val = i
+
+    ! DO CONCURRENT with type-spec should shadow 'i'
+    ! even though kind is the same
+    inner_sum = 0
+    do concurrent (integer :: i = 1:3)
+      inner_sum = inner_sum + i
+    end do
+
+    ! After loop, outer 'i' should be unchanged
+    if (i /= outer_val) stop 2
+    if (i /= 99) stop 3
+    if (inner_sum /= 6) stop 4  ! 1+2+3 = 6
+  end subroutine test_shadow_same_kind
+
+  subroutine test_shadow_different_kind()
+    implicit none
+    integer(kind=4) :: k
+    integer :: result
+
+    ! Set outer 'k' to a value
+    k = 77
+
+    ! DO CONCURRENT with different kind should shadow
+    result = 0
+    do concurrent (integer(kind=2) :: k = 1:4)
+      result = result + int(k, kind=4)
+    end do
+
+    ! Outer 'k' should be unchanged
+    if (k /= 77) stop 5
+    if (result /= 10) stop 6  ! 1+2+3+4 = 10
+  end subroutine test_shadow_different_kind
+
+  subroutine test_multiple_iterators()
+    implicit none
+    integer :: i, j
+    integer :: sum_val
+
+    ! Set outer variables
+    i = 100
+    j = 200
+
+    ! Multiple iterators: i shadows (same kind), m is new (BT_UNKNOWN)
+    ! Per F2018 R1125, ONE type-spec applies to ALL iterators
+    sum_val = 0
+    do concurrent (integer :: i = 1:2, m = 1:2)
+      sum_val = sum_val + i * 10 + m
+    end do
+
+    ! Outer i should be unchanged, j should be unchanged
+    if (i /= 100) stop 7
+    if (j /= 200) stop 8
+    ! sum = (1*10+1) + (1*10+2) + (2*10+1) + (2*10+2) = 11+12+21+22 = 66
+    if (sum_val /= 66) stop 9
+  end subroutine test_multiple_iterators
+
+end program test_do_concurrent_typespec

Reply via email to