Fortran: Add LOCALITY support for DO_CONCURRENT

	This patch provided by Anuj Mohite as part of the GSoC project.
	It is modified slightly by Jerry DeLisle for minor formatting.
	The patch provides front-end parsing of the LOCALITY specs in
	DO_CONCURRENT and adds numerous test cases.

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_code_node):  Updated to use
	c->ext.concur.forall_iterator instead of c->ext.forall_iterator.
	* frontend-passes.cc (index_interchange): Updated to
	use c->ext.concur.forall_iterator instead of c->ext.forall_iterator.
	(gfc_code_walker): Likewise.
	* gfortran.h (enum locality_type): Added new enum for locality types
	in DO CONCURRENT constructs.
	* match.cc (match_simple_forall): Updated to use
	new_st.ext.concur.forall_iterator instead of new_st.ext.forall_iterator.
	(gfc_match_forall): Likewise.
	(gfc_match_do):  Implemented support for matching DO CONCURRENT locality
	specifiers (LOCAL, LOCAL_INIT, SHARED, DEFAULT(NONE), and REDUCE).
	* parse.cc (parse_do_block): Updated to use
	new_st.ext.concur.forall_iterator instead of new_st.ext.forall_iterator.
	* resolve.cc (struct check_default_none_data): Added struct
	check_default_none_data.
	(do_concur_locality_specs_f2023): New function to check compliance
	with F2023's C1133 constraint for DO CONCURRENT.
	(check_default_none_expr): New function to check DEFAULT(NONE)
	compliance.
	(resolve_locality_spec): New function to resolve locality specs.
	(gfc_count_forall_iterators): Updated to use
	code->ext.concur.forall_iterator.
	(gfc_resolve_forall): Updated to use code->ext.concur.forall_iterator.
	* st.cc (gfc_free_statement): Updated to free locality specifications
	and use p->ext.concur.forall_iterator.
	* trans-stmt.cc (gfc_trans_forall_1): Updated to use
	code->ext.concur.forall_iterator.

gcc/testsuite/ChangeLog:

	* gfortran.dg/do_concurrent_10.f90: New test.
	* gfortran.dg/do_concurrent_8_f2018.f90: New test.
	* gfortran.dg/do_concurrent_8_f2023.f90: New test.
	* gfortran.dg/do_concurrent_9.f90: New test.
	* gfortran.dg/do_concurrent_all_clauses.f90: New test.
	* gfortran.dg/do_concurrent_basic.f90: New test.
	* gfortran.dg/do_concurrent_constraints.f90: New test.
	* gfortran.dg/do_concurrent_local_init.f90: New test.
	* gfortran.dg/do_concurrent_locality_specs.f90: New test.
	* gfortran.dg/do_concurrent_multiple_reduce.f90: New test.
	* gfortran.dg/do_concurrent_nested.f90: New test.
	* gfortran.dg/do_concurrent_parser.f90: New test.
	* gfortran.dg/do_concurrent_reduce_max.f90: New test.
	* gfortran.dg/do_concurrent_reduce_sum.f90: New test.
	* gfortran.dg/do_concurrent_shared.f90: New test.

Signed-off-by: Anuj <anujmohite001@gmail.com>

8 files changed, 786 insertions, 36 deletions

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index cf09e8d..0f983e9 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -3005,7 +3005,7 @@ show_code_node (int level, gfc_code *c)
 
     case EXEC_FORALL:
       fputs ("FORALL ", dumpfile);
-      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+      for (fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
 	{
 	  show_expr (fa->var);
 	  fputc (' ', dumpfile);
@@ -3065,7 +3065,7 @@ show_code_node (int level, gfc_code *c)
 
     case EXEC_DO_CONCURRENT:
       fputs ("DO CONCURRENT ", dumpfile);
-      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+      for (fa = c->ext.concur.forall_iterator; fa; fa = fa->next)
         {
           show_expr (fa->var);
           fputc (' ', dumpfile);
@@ -3078,7 +3078,114 @@ show_code_node (int level, gfc_code *c)
           if (fa->next != NULL)
             fputc (',', dumpfile);
         }
-      show_expr (c->expr1);
+
+      if (c->expr1 != NULL)
+	{
+	  fputc (',', dumpfile);
+	  show_expr (c->expr1);
+	}
+
+      if (c->ext.concur.locality[LOCALITY_LOCAL])
+	{
+	  fputs (" LOCAL (", dumpfile);
+
+	  for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_LOCAL];
+	       el; el = el->next)
+	    {
+	      show_expr (el->expr);
+	      if (el->next)
+		fputc (',', dumpfile);
+	    }
+	  fputc (')', dumpfile);
+	}
+
+      if (c->ext.concur.locality[LOCALITY_LOCAL_INIT])
+	{
+	  fputs (" LOCAL_INIT (", dumpfile);
+	  for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_LOCAL_INIT];
+	       el; el = el->next)
+	  {
+	    show_expr (el->expr);
+	    if (el->next)
+	      fputc (',', dumpfile);
+	  }
+	  fputc (')', dumpfile);
+	}
+
+      if (c->ext.concur.locality[LOCALITY_SHARED])
+	{
+	  fputs (" SHARED (", dumpfile);
+	  for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_SHARED];
+	       el; el = el->next)
+	    {
+	      show_expr (el->expr);
+	      if (el->next)
+		fputc (',', dumpfile);
+	    }
+	  fputc (')', dumpfile);
+	}
+
+      if (c->ext.concur.default_none)
+	{
+	  fputs (" DEFAULT (NONE)", dumpfile);
+	}
+
+      if (c->ext.concur.locality[LOCALITY_REDUCE])
+	{
+	  gfc_expr_list *el = c->ext.concur.locality[LOCALITY_REDUCE];
+	  while (el)
+	    {
+	      fputs (" REDUCE (", dumpfile);
+	      if (el->expr)
+		{
+		  if (el->expr->expr_type == EXPR_FUNCTION)
+		    {
+		      const char *name;
+		      switch (el->expr->value.function.isym->id)
+			{
+			  case GFC_ISYM_MIN:
+			    name = "MIN";
+			    break;
+			  case GFC_ISYM_MAX:
+			    name = "MAX";
+			    break;
+			  case GFC_ISYM_IAND:
+			    name = "IAND";
+			    break;
+			  case GFC_ISYM_IOR:
+			    name = "IOR";
+			    break;
+			  case GFC_ISYM_IEOR:
+			    name = "IEOR";
+			    break;
+			  default:
+			    gcc_unreachable ();
+			}
+		      fputs (name, dumpfile);
+		    }
+		  else
+		    show_expr (el->expr);
+		}
+	      else
+		{
+		  fputs ("(NULL)", dumpfile);
+		}
+
+	      fputc (':', dumpfile);
+	      el = el->next;
+
+	      while (el && el->expr && el->expr->expr_type == EXPR_VARIABLE)
+		{
+		  show_expr (el->expr);
+		  el = el->next;
+		  if (el && el->expr && el->expr->expr_type == EXPR_VARIABLE)
+		    fputc (',', dumpfile);
+		}
+
+	      fputc (')', dumpfile);
+	    }
+	}
+
       ++show_level;
 
       show_code (level + 1, c->block->next);
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 6ee6ce4..9872387 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5132,7 +5132,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     return 0;
 
   n_iter = 0;
-  for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
     n_iter ++;
 
   /* Nothing to reorder. */
@@ -5142,7 +5142,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
   ind = XALLOCAVEC (ind_type, n_iter + 1);
 
   i = 0;
-  for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
     {
       ind[i].sym = fa->var->symtree->n.sym;
       ind[i].fa = fa;
@@ -5158,7 +5158,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
   qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
 
   /* Do the actual index interchange.  */
-  co->ext.forall_iterator = fa = ind[0].fa;
+  co->ext.concur.forall_iterator = fa = ind[0].fa;
   for (i=1; i<n_iter; i++)
     {
       fa->next = ind[i].fa;
@@ -5410,7 +5410,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 	    case EXEC_DO_CONCURRENT:
 	      {
 		gfc_forall_iterator *fa;
-		for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+		for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
 		  {
 		    WALK_SUBEXPR (fa->var);
 		    WALK_SUBEXPR (fa->start);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 70913e3..7367db8 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3111,6 +3111,16 @@ enum gfc_exec_op
   EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH
 };
 
+/* Enum Definition for locality types.  */
+enum locality_type
+{
+  LOCALITY_LOCAL = 0,
+  LOCALITY_LOCAL_INIT,
+  LOCALITY_SHARED,
+  LOCALITY_REDUCE,
+  LOCALITY_NUM
+};
+
 typedef struct gfc_code
 {
   gfc_exec_op op;
@@ -3131,6 +3141,20 @@ typedef struct gfc_code
   {
     gfc_actual_arglist *actual;
     gfc_iterator *iterator;
+    gfc_open *open;
+    gfc_close *close;
+    gfc_filepos *filepos;
+    gfc_inquire *inquire;
+    gfc_wait *wait;
+    gfc_dt *dt;
+    struct gfc_code *which_construct;
+    gfc_entry_list *entry;
+    gfc_oacc_declare *oacc_declare;
+    gfc_omp_clauses *omp_clauses;
+    const char *omp_name;
+    gfc_omp_namelist *omp_namelist;
+    bool omp_bool;
+    int stop_code;
 
     struct
     {
@@ -3152,21 +3176,13 @@ typedef struct gfc_code
     }
     block;
 
-    gfc_open *open;
-    gfc_close *close;
-    gfc_filepos *filepos;
-    gfc_inquire *inquire;
-    gfc_wait *wait;
-    gfc_dt *dt;
-    gfc_forall_iterator *forall_iterator;
-    struct gfc_code *which_construct;
-    int stop_code;
-    gfc_entry_list *entry;
-    gfc_oacc_declare *oacc_declare;
-    gfc_omp_clauses *omp_clauses;
-    const char *omp_name;
-    gfc_omp_namelist *omp_namelist;
-    bool omp_bool;
+    struct
+    {
+      gfc_forall_iterator *forall_iterator;
+      gfc_expr_list *locality[LOCALITY_NUM];
+      bool default_none;
+    }
+    concur;
   }
   ext;		/* Points to additional structures required by statement */
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index e064cab..c3c3305 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2568,7 +2568,7 @@ match_simple_forall (void)
   gfc_clear_new_st ();
   new_st.op = EXEC_FORALL;
   new_st.expr1 = mask;
-  new_st.ext.forall_iterator = head;
+  new_st.ext.concur.forall_iterator = head;
   new_st.block = gfc_get_code (EXEC_FORALL);
   new_st.block->next = c;
 
@@ -2618,7 +2618,7 @@ gfc_match_forall (gfc_statement *st)
       *st = ST_FORALL_BLOCK;
       new_st.op = EXEC_FORALL;
       new_st.expr1 = mask;
-      new_st.ext.forall_iterator = head;
+      new_st.ext.concur.forall_iterator = head;
       return MATCH_YES;
     }
 
@@ -2641,7 +2641,7 @@ gfc_match_forall (gfc_statement *st)
   gfc_clear_new_st ();
   new_st.op = EXEC_FORALL;
   new_st.expr1 = mask;
-  new_st.ext.forall_iterator = head;
+  new_st.ext.concur.forall_iterator = head;
   new_st.block = gfc_get_code (EXEC_FORALL);
   new_st.block->next = c;
 
@@ -2703,9 +2703,20 @@ gfc_match_do (void)
   if (gfc_match_parens () == MATCH_ERROR)
     return MATCH_ERROR;
 
+  /* Handle DO CONCURRENT construct.  */
+
   if (gfc_match (" concurrent") == MATCH_YES)
     {
-      gfc_forall_iterator *head;
+      gfc_forall_iterator *head = NULL;
+      gfc_expr_list *local = NULL;
+      gfc_expr_list *local_tail = NULL;
+      gfc_expr_list *local_init = NULL;
+      gfc_expr_list *local_init_tail = NULL;
+      gfc_expr_list *shared = NULL;
+      gfc_expr_list *shared_tail = NULL;
+      gfc_expr_list *reduce = NULL;
+      gfc_expr_list *reduce_tail = NULL;
+      bool default_none = false;
       gfc_expr *mask;
 
       if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
@@ -2717,6 +2728,258 @@ gfc_match_do (void)
       m = match_forall_header (&head, &mask);
 
       if (m == MATCH_NO)
+	goto match_do_loop;
+      if (m == MATCH_ERROR)
+	goto concurr_cleanup;
+
+      while (true)
+	{
+	  gfc_gobble_whitespace ();
+	  locus where = gfc_current_locus;
+
+	  if (gfc_match_eos () == MATCH_YES)
+	    break;
+
+	  else if (gfc_match ("local ( ") == MATCH_YES)
+	    {
+	      gfc_expr *e;
+	      while (true)
+		{
+		  if (gfc_match_variable (&e, 0) != MATCH_YES)
+		    goto concurr_cleanup;
+
+		  if (local == NULL)
+		    local = local_tail = gfc_get_expr_list ();
+
+		  else
+		    {
+		      local_tail->next = gfc_get_expr_list ();
+		      local_tail = local_tail->next;
+		    }
+		  local_tail->expr = e;
+
+		  if (gfc_match_char (',') == MATCH_YES)
+		    continue;
+		  if (gfc_match_char (')') == MATCH_YES)
+		    break;
+		  goto concurr_cleanup;
+		}
+	    }
+
+	    else if (gfc_match ("local_init ( ") == MATCH_YES)
+	      {
+		gfc_expr *e;
+
+		while (true)
+		  {
+		    if (gfc_match_variable (&e, 0) != MATCH_YES)
+		      goto concurr_cleanup;
+
+		    if (local_init == NULL)
+		      local_init = local_init_tail = gfc_get_expr_list ();
+
+		    else
+		      {
+			local_init_tail->next = gfc_get_expr_list ();
+			local_init_tail = local_init_tail->next;
+		      }
+		    local_init_tail->expr = e;
+
+		    if (gfc_match_char (',') == MATCH_YES)
+		      continue;
+		    if (gfc_match_char (')') == MATCH_YES)
+		      break;
+		    goto concurr_cleanup;
+		  }
+	      }
+
+	    else if (gfc_match ("shared ( ") == MATCH_YES)
+	      {
+		gfc_expr *e;
+		while (true)
+		  {
+		    if (gfc_match_variable (&e, 0) != MATCH_YES)
+		      goto concurr_cleanup;
+
+		    if (shared == NULL)
+		      shared = shared_tail = gfc_get_expr_list ();
+
+		    else
+		      {
+			shared_tail->next = gfc_get_expr_list ();
+			shared_tail = shared_tail->next;
+		      }
+		    shared_tail->expr = e;
+
+		    if (gfc_match_char (',') == MATCH_YES)
+		      continue;
+		    if (gfc_match_char (')') == MATCH_YES)
+		      break;
+		    goto concurr_cleanup;
+		  }
+	      }
+
+	    else if (gfc_match ("default (none)") == MATCH_YES)
+	      {
+		if (default_none)
+		  {
+		    gfc_error ("DEFAULT (NONE) specified more than once in DO "
+			       "CONCURRENT at %C");
+		    goto concurr_cleanup;
+		  }
+		default_none = true;
+	      }
+
+	    else if (gfc_match ("reduce ( ") == MATCH_YES)
+	      {
+		gfc_expr *reduction_expr;
+		where = gfc_current_locus;
+
+		if (gfc_match_char ('+') == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_PLUS,
+							  NULL, NULL);
+
+		else if (gfc_match_char ('*') == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_TIMES,
+							  NULL, NULL);
+
+		else if (gfc_match (".and.") == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_AND,
+							  NULL, NULL);
+
+		else if (gfc_match (".or.") == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_OR,
+							  NULL, NULL);
+
+		else if (gfc_match (".eqv.") == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_EQV,
+							  NULL, NULL);
+
+		else if (gfc_match (".neqv.") == MATCH_YES)
+		  reduction_expr = gfc_get_operator_expr (&where,
+							  INTRINSIC_NEQV,
+							  NULL, NULL);
+
+		else if (gfc_match ("min") == MATCH_YES)
+		  {
+		    reduction_expr = gfc_get_expr ();
+		    reduction_expr->expr_type = EXPR_FUNCTION;
+		    reduction_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_MIN);
+		    reduction_expr->where = where;
+		  }
+
+		else if (gfc_match ("max") == MATCH_YES)
+		  {
+		    reduction_expr = gfc_get_expr ();
+		    reduction_expr->expr_type = EXPR_FUNCTION;
+		    reduction_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_MAX);
+		    reduction_expr->where = where;
+		  }
+
+		else if (gfc_match ("iand") == MATCH_YES)
+		  {
+		    reduction_expr = gfc_get_expr ();
+		    reduction_expr->expr_type = EXPR_FUNCTION;
+		    reduction_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_IAND);
+		    reduction_expr->where = where;
+		  }
+
+		else if (gfc_match ("ior") == MATCH_YES)
+		  {
+		    reduction_expr = gfc_get_expr ();
+		    reduction_expr->expr_type = EXPR_FUNCTION;
+		    reduction_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_IOR);
+		    reduction_expr->where = where;
+		  }
+
+		else if (gfc_match ("ieor") == MATCH_YES)
+		  {
+		    reduction_expr = gfc_get_expr ();
+		    reduction_expr->expr_type = EXPR_FUNCTION;
+		    reduction_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_IEOR);
+		    reduction_expr->where = where;
+		  }
+
+		else
+		  {
+		    gfc_error ("Expected reduction operator or function name "
+			       "at %C");
+		    goto concurr_cleanup;
+		  }
+
+		if (!reduce)
+		  {
+		    reduce = reduce_tail = gfc_get_expr_list ();
+		  }
+		else
+		  {
+		    reduce_tail->next = gfc_get_expr_list ();
+		    reduce_tail = reduce_tail->next;
+		  }
+		reduce_tail->expr = reduction_expr;
+
+		gfc_gobble_whitespace ();
+
+		if (gfc_match_char (':') != MATCH_YES)
+		  {
+		    gfc_error ("Expected %<:%> at %C");
+		    goto concurr_cleanup;
+		  }
+
+		while (true)
+		  {
+		    gfc_expr *reduction_expr;
+
+		    if (gfc_match_variable (&reduction_expr, 0) != MATCH_YES)
+		      {
+			gfc_error ("Expected variable name in reduction list "
+				   "at %C");
+			goto concurr_cleanup;
+		      }
+
+		    if (reduce == NULL)
+		      reduce = reduce_tail = gfc_get_expr_list ();
+		    else
+		      {
+			reduce_tail = reduce_tail->next = gfc_get_expr_list ();
+			reduce_tail->expr = reduction_expr;
+		      }
+
+		    if (gfc_match_char (',') == MATCH_YES)
+		      continue;
+		    else if (gfc_match_char (')') == MATCH_YES)
+		      break;
+		    else
+		      {
+			gfc_error ("Expected ',' or ')' in reduction list "
+				   "at %C");
+			goto concurr_cleanup;
+		      }
+		  }
+
+		if (!gfc_notify_std (GFC_STD_F2023, "REDUCE locality spec at "
+				     "%L", &where))
+		  goto concurr_cleanup;
+	      }
+	    else
+	      goto concurr_cleanup;
+
+	    if (!gfc_notify_std (GFC_STD_F2018, "Locality spec at %L",
+				 &gfc_current_locus))
+	      goto concurr_cleanup;
+	}
+
+      if (m == MATCH_NO)
 	return m;
       if (m == MATCH_ERROR)
 	goto concurr_cleanup;
@@ -2731,14 +2994,26 @@ gfc_match_do (void)
       new_st.label1 = label;
       new_st.op = EXEC_DO_CONCURRENT;
       new_st.expr1 = mask;
-      new_st.ext.forall_iterator = head;
+      new_st.ext.concur.forall_iterator = head;
+      new_st.ext.concur.locality[LOCALITY_LOCAL] = local;
+      new_st.ext.concur.locality[LOCALITY_LOCAL_INIT] = local_init;
+      new_st.ext.concur.locality[LOCALITY_SHARED] = shared;
+      new_st.ext.concur.locality[LOCALITY_REDUCE] = reduce;
+      new_st.ext.concur.default_none = default_none;
 
       return MATCH_YES;
 
 concurr_cleanup:
-      gfc_syntax_error (ST_DO);
       gfc_free_expr (mask);
       gfc_free_forall_iterator (head);
+      gfc_free_expr_list (local);
+      gfc_free_expr_list (local_init);
+      gfc_free_expr_list (shared);
+      gfc_free_expr_list (reduce);
+
+      if (!gfc_error_check ())
+	gfc_syntax_error (ST_DO);
+
       return MATCH_ERROR;
     }
 
@@ -2749,6 +3024,7 @@ concurr_cleanup:
       goto done;
     }
 
+match_do_loop:
   /* The abortive DO WHILE may have done something to the symbol
      table, so we start over.  */
   gfc_undo_symbols ();
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index f65449d..fbecb17 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5411,7 +5411,7 @@ parse_do_block (void)
   if (do_op == EXEC_DO_CONCURRENT)
     {
       gfc_forall_iterator *fa;
-      for (fa = new_st.ext.forall_iterator; fa; fa = fa->next)
+      for (fa = new_st.ext.concur.forall_iterator; fa; fa = fa->next)
 	{
 	  /* Apply unroll only to innermost loop (first control
 	     variable).  */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index dab0c3a..3e74a2e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -54,6 +54,13 @@ code_stack;
 
 static code_stack *cs_base = NULL;
 
+struct check_default_none_data
+{
+  gfc_code *code;
+  hash_set<gfc_symbol *> *sym_hash;
+  gfc_namespace *ns;
+  bool default_none;
+};
 
 /* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
 
@@ -8622,6 +8629,344 @@ find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
     return false;
 }
 
+/* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT
+   This constraint specifies rules for variables in locality-specs.  */
+
+static int
+do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data)
+{
+  struct check_default_none_data *dt = (struct check_default_none_data *) data;
+
+  if ((*expr)->expr_type == EXPR_VARIABLE)
+    {
+      gfc_symbol *sym = (*expr)->symtree->n.sym;
+      for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL];
+	   list; list = list->next)
+	{
+	  if (list->expr->symtree->n.sym == sym)
+	    {
+	      gfc_error ("Variable %qs referenced in concurrent-header at %L "
+			 "must not appear in LOCAL locality-spec at %L",
+			 sym->name, &(*expr)->where, &list->expr->where);
+	      *walk_subtrees = 0;
+	      return 1;
+	    }
+	}
+    }
+
+    *walk_subtrees = 1;
+    return 0;
+}
+
+static int
+check_default_none_expr (gfc_expr **e, int *, void *data)
+{
+  struct check_default_none_data *d = (struct check_default_none_data*) data;
+
+  if ((*e)->expr_type == EXPR_VARIABLE)
+    {
+      gfc_symbol *sym = (*e)->symtree->n.sym;
+
+      if (d->sym_hash->contains (sym))
+	sym->mark = 1;
+
+      else if (d->default_none)
+	{
+	  gfc_namespace *ns2 = d->ns;
+	  while (ns2)
+	    {
+	      if (ns2 == sym->ns)
+		break;
+	      ns2 = ns2->parent;
+	    }
+	  if (ns2 != NULL)
+	    {
+	      gfc_error ("Variable %qs at %L not specified in a locality spec "
+			"of DO CONCURRENT at %L but required due to "
+			"DEFAULT (NONE)",
+			sym->name, &(*e)->where, &d->code->loc);
+	      d->sym_hash->add (sym);
+	    }
+	}
+    }
+  return 0;
+}
+
+static void
+resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
+{
+  struct check_default_none_data data;
+  data.code = code;
+  data.sym_hash = new hash_set<gfc_symbol *>;
+  data.ns = ns;
+  data.default_none = code->ext.concur.default_none;
+
+  for (int locality = 0; locality < LOCALITY_NUM; locality++)
+    {
+      const char *name;
+      switch (locality)
+	{
+	  case LOCALITY_LOCAL: name = "LOCAL"; break;
+	  case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break;
+	  case LOCALITY_SHARED: name = "SHARED"; break;
+	  case LOCALITY_REDUCE: name = "REDUCE"; break;
+	  default: gcc_unreachable ();
+	}
+
+      for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
+	   list = list->next)
+	{
+	  gfc_expr *expr = list->expr;
+
+	  if (locality == LOCALITY_REDUCE
+	      && (expr->expr_type == EXPR_FUNCTION
+		  || expr->expr_type == EXPR_OP))
+	    continue;
+
+	  if (!gfc_resolve_expr (expr))
+	    continue;
+
+	  if (expr->expr_type != EXPR_VARIABLE
+	      || expr->symtree->n.sym->attr.flavor != FL_VARIABLE
+	      || (expr->ref
+		  && (expr->ref->type != REF_ARRAY
+		      || expr->ref->u.ar.type != AR_FULL
+		      || expr->ref->next)))
+	    {
+	      gfc_error ("Expected variable name in %s locality spec at %L",
+			 name, &expr->where);
+		continue;
+	    }
+
+	  gfc_symbol *sym = expr->symtree->n.sym;
+
+	  if (data.sym_hash->contains (sym))
+	    {
+	      gfc_error ("Variable %qs at %L has already been specified in a "
+			 "locality-spec", sym->name, &expr->where);
+	      continue;
+	    }
+
+	  for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
+	       iter; iter = iter->next)
+	    {
+	      if (iter->var->symtree->n.sym == sym)
+		{
+		  gfc_error ("Index variable %qs at %L cannot be specified in a"
+			     "locality-spec", sym->name, &expr->where);
+		  continue;
+		}
+
+	      data.sym_hash->add (iter->var->symtree->n.sym);
+	    }
+
+	  if (locality == LOCALITY_LOCAL
+	      || locality == LOCALITY_LOCAL_INIT
+	      || locality == LOCALITY_REDUCE)
+	    {
+	      if (sym->attr.optional)
+		gfc_error ("OPTIONAL attribute not permitted for %qs in %s "
+			   "locality-spec at %L",
+			   sym->name, name, &expr->where);
+
+	      if (sym->attr.dimension
+		  && sym->as
+		  && sym->as->type == AS_ASSUMED_SIZE)
+		gfc_error ("Assumed-size array not permitted for %qs in %s "
+			   "locality-spec at %L",
+			   sym->name, name, &expr->where);
+
+	      gfc_check_vardef_context (expr, false, false, false, name);
+	    }
+
+	  if (locality == LOCALITY_LOCAL
+	      || locality == LOCALITY_LOCAL_INIT)
+	    {
+	      symbol_attribute attr = gfc_expr_attr (expr);
+
+	      if (attr.allocatable)
+		gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s "
+			   "locality-spec at %L",
+			   sym->name, name, &expr->where);
+
+	      else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer)
+		gfc_error ("Nonpointer polymorphic dummy argument not permitted"
+			   " for %qs in %s locality-spec at %L",
+			   sym->name, name, &expr->where);
+
+	      else if (attr.codimension)
+		gfc_error ("Coarray not permitted for %qs in %s locality-spec "
+			   "at %L",
+			   sym->name, name, &expr->where);
+
+	      else if (expr->ts.type == BT_DERIVED
+		       && gfc_is_finalizable (expr->ts.u.derived, NULL))
+		gfc_error ("Finalizable type not permitted for %qs in %s "
+			   "locality-spec at %L",
+			   sym->name, name, &expr->where);
+
+	      else if (gfc_has_ultimate_allocatable (expr))
+		gfc_error ("Type with ultimate allocatable component not "
+			   "permitted for %qs in %s locality-spec at %L",
+			   sym->name, name, &expr->where);
+	    }
+
+	  else if (locality == LOCALITY_REDUCE)
+	    {
+	      if (sym->attr.asynchronous)
+		gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in "
+			   "REDUCE locality-spec at %L",
+			   sym->name, &expr->where);
+	      if (sym->attr.volatile_)
+		gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE "
+			   "locality-spec at %L", sym->name, &expr->where);
+	    }
+
+	  data.sym_hash->add (sym);
+	}
+
+      if (locality == LOCALITY_LOCAL)
+	{
+	  gcc_assert (locality == 0);
+
+	  for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator;
+	       iter; iter = iter->next)
+	    {
+	      gfc_expr_walker (&iter->start,
+			       do_concur_locality_specs_f2023,
+			       &data);
+
+	      gfc_expr_walker (&iter->end,
+			       do_concur_locality_specs_f2023,
+			       &data);
+
+	      gfc_expr_walker (&iter->stride,
+			       do_concur_locality_specs_f2023,
+			       &data);
+	    }
+
+	  if (code->expr1)
+	    gfc_expr_walker (&code->expr1,
+			     do_concur_locality_specs_f2023,
+			     &data);
+	}
+    }
+
+  gfc_expr *reduce_op = NULL;
+
+  for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE];
+       list; list = list->next)
+    {
+      gfc_expr *expr = list->expr;
+
+      if (expr->expr_type != EXPR_VARIABLE)
+	{
+	  reduce_op = expr;
+	  continue;
+	}
+
+      if (reduce_op->expr_type == EXPR_OP)
+	{
+	  switch (reduce_op->value.op.op)
+	    {
+	      case INTRINSIC_PLUS:
+	      case INTRINSIC_TIMES:
+		if (!gfc_numeric_ts (&expr->ts))
+		  gfc_error ("Expected numeric type for %qs in REDUCE at %L, "
+			     "got %s", expr->symtree->n.sym->name,
+			     &expr->where, gfc_basic_typename (expr->ts.type));
+		break;
+	      case INTRINSIC_AND:
+	      case INTRINSIC_OR:
+	      case INTRINSIC_EQV:
+	      case INTRINSIC_NEQV:
+		if (expr->ts.type != BT_LOGICAL)
+		  gfc_error ("Expected logical type for %qs in REDUCE at %L, "
+			     "got %qs", expr->symtree->n.sym->name,
+			     &expr->where, gfc_basic_typename (expr->ts.type));
+		break;
+	      default:
+		gcc_unreachable ();
+	    }
+	}
+
+      else if (reduce_op->expr_type == EXPR_FUNCTION)
+	{
+	  switch (reduce_op->value.function.isym->id)
+	    {
+	      case GFC_ISYM_MIN:
+	      case GFC_ISYM_MAX:
+		if (expr->ts.type != BT_INTEGER
+		    && expr->ts.type != BT_REAL
+		    && expr->ts.type != BT_CHARACTER)
+		  gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs "
+			     "in REDUCE with MIN/MAX at %L, got %s",
+			     expr->symtree->n.sym->name, &expr->where,
+			     gfc_basic_typename (expr->ts.type));
+		break;
+	      case GFC_ISYM_IAND:
+	      case GFC_ISYM_IOR:
+	      case GFC_ISYM_IEOR:
+		if (expr->ts.type != BT_INTEGER)
+		  gfc_error ("Expected integer type for %qs in REDUCE with "
+			     "IAND/IOR/IEOR at %L, got %s",
+			     expr->symtree->n.sym->name, &expr->where,
+			     gfc_basic_typename (expr->ts.type));
+		break;
+	      default:
+		gcc_unreachable ();
+	    }
+	}
+
+      else
+	gcc_unreachable ();
+    }
+
+  for (int locality = 0; locality < LOCALITY_NUM; locality++)
+    {
+      for (gfc_expr_list *list = code->ext.concur.locality[locality]; list;
+	   list = list->next)
+	{
+	  if (list->expr->expr_type == EXPR_VARIABLE)
+	    list->expr->symtree->n.sym->mark = 0;
+	}
+    }
+
+  gfc_code_walker (&code->block->next, gfc_dummy_code_callback,
+		   check_default_none_expr, &data);
+
+  for (int locality = 0; locality < LOCALITY_NUM; locality++)
+    {
+      gfc_expr_list **plist = &code->ext.concur.locality[locality];
+      while (*plist)
+	{
+	  gfc_expr *expr = (*plist)->expr;
+	  if (expr->expr_type == EXPR_VARIABLE)
+	    {
+	      gfc_symbol *sym = expr->symtree->n.sym;
+	      if (sym->mark == 0)
+		{
+		  gfc_warning (OPT_Wunused_variable, "Variable %qs in "
+			       "locality-spec at %L is not used",
+			       sym->name, &expr->where);
+		  gfc_expr_list *tmp = *plist;
+		  *plist = (*plist)->next;
+		  gfc_free_expr (tmp->expr);
+		  free (tmp);
+		  continue;
+		}
+	    }
+	  plist = &((*plist)->next);
+	}
+    }
+
+  if (code->ext.concur.locality[LOCALITY_LOCAL]
+      || code->ext.concur.locality[LOCALITY_LOCAL_INIT])
+    {
+      gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for "
+		 "%<do concurrent%> constructs at %L", &code->loc);
+    }
+}
 
 /* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
    to be a scalar INTEGER variable.  The subscripts and stride are scalar
@@ -12079,7 +12424,7 @@ gfc_count_forall_iterators (gfc_code *code)
   max_iters = 0;
   current_iters = 0;
 
-  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
     current_iters ++;
 
   code = code->block->next;
@@ -12129,7 +12474,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
 
   /* The information about FORALL iterator, including FORALL indices start, end
      and stride.  An outer FORALL indice cannot appear in start, end or stride.  */
-  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
     {
       /* Fortran 20008: C738 (R753).  */
       if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
@@ -13961,12 +14306,15 @@ start:
 
 	case EXEC_DO_CONCURRENT:
 	case EXEC_FORALL:
-	  resolve_forall_iterators (code->ext.forall_iterator);
+	  resolve_forall_iterators (code->ext.concur.forall_iterator);
 
 	  if (code->expr1 != NULL
 	      && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
 	    gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
 		       "expression", &code->expr1->where);
+
+    if (code->op == EXEC_DO_CONCURRENT)
+      resolve_locality_spec (code, ns);
 	  break;
 
 	case EXEC_OACC_PARALLEL_LOOP:
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 0ee85c4..509d28c 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -189,8 +189,11 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_DO_CONCURRENT:
+      for (int i = 0; i < LOCALITY_NUM; i++)
+	gfc_free_expr_list (p->ext.concur.locality[i]);
+      gcc_fallthrough ();
     case EXEC_FORALL:
-      gfc_free_forall_iterator (p->ext.forall_iterator);
+      gfc_free_forall_iterator (p->ext.concur.forall_iterator);
       break;
 
     case EXEC_OACC_DECLARE:
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index d22ea8a..e7da8fe 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -5165,7 +5165,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
 
   n = 0;
   /* Count the FORALL index number.  */
-  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
     n++;
   nvar = n;
 
@@ -5185,7 +5185,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
   gfc_init_block (&block);
 
   n = 0;
-  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+  for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
     {
       gfc_symbol *sym = fa->var->symtree->n.sym;
 
@@ -5446,7 +5446,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
 
 done:
   /* Restore the original index variables.  */
-  for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
+  for (fa = code->ext.concur.forall_iterator, n = 0; fa; fa = fa->next, n++)
     gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
 
   /* Free the space for var, start, end, step, varexpr.  */