diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index cf09e8d5b823440fe253bc6b8e5f943eb422346c..0f983e98a5ec46064bb79398915937140a772037 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 6ee6ce4c3ff11328eb1f062fa34ea315be329533..987238794dabd5180e43a28912fc2c95f0d1fea7 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 70913e3312b2309819d94419d5d91008e9f70a71..7367db8853c65280433d0fba90f03fff65db540e 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 e064cab5c80d7184f264cc015a3b73208ad9025d..c3c330520d6f2ddee51aa9a3a2bbe80938f9fa27 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"))
@@ -2716,6 +2727,258 @@ gfc_match_do (void)
head = NULL;
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)
@@ -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 f65449df9e2ee31bfe8860ecc80d5936595c25a1..fbecb174437680dc710cda4f271459f62e05d4e4 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 dab0c3af6018b5d60ae861138fc09dfc0644d820..3e74a2e50883ed4c8e5eca0a49a67aa8956d119f 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 0ee85c41292b38ac58957119c813103a0fd53943..509d28c23bdab44b322bd6f5db0e3926e49a7825 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 d22ea8a4628a57ab83f8f102a200d74c44a2cade..e7da8fea3b24c77b6d9bba95ab0c6f558b11db83 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. */
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_10.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_10.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6bbeb3bc990da1141c572f85066595cb628478ec
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_10.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! { dg-options "-std=f2018" }
+
+program do_concurrent_parsing
+ implicit none
+ integer :: concurrent, do
+ do concurrent = 1, 5
+ end do
+ do concurrent = 1, 5
+ end do
+end program do_concurrent_parsing
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7449026dea8f5255f8d73304740641d50e811284
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! { dg-options "-std=f2018" }
+program do_concurrent_complex
+ implicit none
+ integer :: i, j, k, sum, product
+ integer, dimension(10,10,10) :: array
+ sum = 0
+ product = 1
+ do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum) ! { dg-error "Fortran 2023: REDUCE locality spec" }
+ do concurrent (j = 1:10) local(k) shared(product) reduce(*:product) ! { dg-error "Fortran 2023: REDUCE locality spec" }
+ do concurrent (k = 1:10)
+ array(i,j,k) = i * j * k
+ sum = sum + array(i,j,k)
+ product = product * array(i,j,k)
+ end do
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ print *, sum, product
+end program do_concurrent_complex
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a99d81e4a5c3af3bcbc365ffa4fc2a6d8cdeb25c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-std=gnu" }
+program do_concurrent_complex
+ implicit none
+ integer :: i, j, k, sum, product
+ integer, dimension(10,10,10) :: array
+ sum = 0
+ product = 1
+ do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum)
+ ! { dg-error "Variable .sum. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 }
+ ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 }
+ do concurrent (j = 1:10) local(k) shared(product) reduce(*:product)
+ ! { dg-error "Variable .product. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 }
+ ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 }
+ do concurrent (k = 1:10)
+ array(i,j,k) = i * j * k
+ sum = sum + array(i,j,k)
+ product = product * array(i,j,k)
+ end do
+ end do
+ end do
+ print *, sum, product
+end program do_concurrent_complex
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90
new file mode 100644
index 0000000000000000000000000000000000000000..98cef3ec588f4d44d019fe161f7e5e35f8cd92f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f2018" }
+program do_concurrent_default_none
+ implicit none
+ integer :: i, x, y, z
+ x = 0
+ y = 0
+ z = 0
+ do concurrent (i = 1:10) default(none) shared(x) local(y) ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported" }
+ ! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT \\(NONE\\)" "" { target *-*-* } .-1 }
+ x = x + i
+ y = i * 2
+ z = z + 1 ! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT \\(NONE\\)" }
+ end do
+end program do_concurrent_default_none
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2e1c18cbf5cf601add3d6efc1f17d07da09f41a3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+program do_concurrent_all_clauses
+ implicit none
+ integer :: i, arr(10), sum, max_val, temp, squared
+ sum = 0
+ max_val = 0
+
+ do concurrent (i = 1:10, i <= 8) &
+ default(none) &
+ local(temp) &
+ shared(arr, squared, sum, max_val) &
+ reduce(+:sum) & ! { dg-error "Variable 'sum' at \\(1\\) has already been specified in a locality-spec" }
+ reduce(max:max_val) ! { dg-error "Variable 'max_val' at \\(1\\) has already been specified in a locality-spec" }
+ ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported*" "" { target *-*-* } .-1 }
+ block
+ integer :: temp2
+ temp = i * 2
+ temp2 = temp * 2
+ squared = i * i
+ arr(i) = temp2 + squared
+ sum = sum + arr(i)
+ max_val = max(max_val, arr(i)) ! { dg-error "Reference to impure function" }
+ end block
+ end do
+ print *, arr, sum, max_val
+end program do_concurrent_all_clauses
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fe8723d48b4c389f8066728e43a0d588f20f03e3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90
@@ -0,0 +1,11 @@
+! { dg-do run }
+program basic_do_concurrent
+ implicit none
+ integer :: i, arr(10)
+
+ do concurrent (i = 1:10)
+ arr(i) = i
+ end do
+
+ print *, arr
+end program basic_do_concurrent
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5716fc30b86c4f9e5a2fb8ab278ff7d01e0b874d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90
@@ -0,0 +1,126 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+
+module m
+ type t1
+ integer, allocatable :: x
+ end type t1
+
+ type t2
+ type(t1), allocatable :: y
+ end type t2
+
+ type, abstract :: abstract_type
+ end type abstract_type
+
+contains
+ subroutine test_c1130(a, b, c, d, e, f, g, h, j)
+ integer, allocatable :: a
+ integer, intent(in) :: b
+ integer, optional :: c
+ type(t1) :: d
+ real :: e[*]
+ integer :: f(*)
+ type(t2) :: g
+ class(abstract_type), pointer :: h
+ class(abstract_type) :: j
+ integer :: i
+
+ ! C1130 tests
+ do concurrent (i=1:5) local(a) ! { dg-error "ALLOCATABLE attribute not permitted for 'a' in LOCAL locality-spec" }
+ end do
+ do concurrent (i=1:5) local(b) ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(LOCAL\\) at" }
+ end do
+ do concurrent (i=1:5) local(c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in LOCAL locality-spec" }
+ end do
+ do concurrent (i=1:5) local(d) ! { dg-error "Type with ultimate allocatable component not permitted for 'd' in LOCAL locality-spec" }
+ end do
+ do concurrent (i=1:5) local(e) ! { dg-error "Expected variable name in LOCAL locality spec" }
+ end do
+ do concurrent (i=1:5) local(f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" }
+ end do
+ do concurrent (i=1:5) local(g) ! { dg-error "Type with ultimate allocatable component not permitted for 'g' in LOCAL locality-spec" }
+ end do
+ do concurrent (i=1:5) local(h)
+ end do
+ do concurrent (i=1:5) local(j) ! { dg-error "Nonpointer polymorphic dummy argument not permitted for 'j' in LOCAL locality-spec" }
+ end do
+
+ ! LOCAL_INIT tests
+ do concurrent (i=1:5) local_init(a) ! { dg-error "ALLOCATABLE attribute not permitted for 'a' in LOCAL_INIT locality-spec" }
+ end do
+ do concurrent (i=1:5) local_init(b) ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(LOCAL_INIT\\) at" }
+ end do
+ do concurrent (i=1:5) local_init(c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in LOCAL_INIT locality-spec" }
+ end do
+ do concurrent (i=1:5) local_init(d) ! { dg-error "Type with ultimate allocatable component not permitted for 'd' in LOCAL_INIT locality-spec" }
+ end do
+ do concurrent (i=1:5) local_init(e) ! { dg-error "Expected variable name in LOCAL_INIT locality spec" }
+ end do
+ do concurrent (i=1:5) local_init(f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" }
+ end do
+ do concurrent (i=1:5) local_init(g) ! { dg-error "Type with ultimate allocatable component not permitted for 'g' in LOCAL_INIT locality-spec" }
+ end do
+ do concurrent (i=1:5) local_init(h)
+ end do
+ do concurrent (i=1:5) local_init(j) ! { dg-error "Nonpointer polymorphic dummy argument not permitted for 'j' in LOCAL_INIT locality-spec" }
+ end do
+ end subroutine test_c1130
+
+ subroutine test_c1131(a, b, c, d, e, f, g)
+ integer, asynchronous :: a
+ integer, intent(in) :: b
+ integer, optional :: c
+ integer, volatile :: d
+ real :: e[*]
+ integer :: f(*)
+ real :: g(3)[*]
+ integer :: i
+
+ ! C1131 tests
+ do concurrent (i=1:5) reduce(+:a) ! { dg-error "ASYNCHRONOUS attribute not permitted for 'a' in REDUCE locality-spec" }
+ end do
+ do concurrent (i=1:5) reduce(+:b)
+ ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(REDUCE\\)" "" { target *-*-* } .-1 }
+ end do
+ do concurrent (i=1:5) reduce(+:c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in REDUCE locality-spec" }
+ end do
+ do concurrent (i=1:5) reduce(+:d) ! { dg-error "VOLATILE attribute not permitted for 'd' in REDUCE locality-spec" }
+ end do
+ do concurrent (i=1:5) reduce(+:e) ! { dg-error "Expected variable name in REDUCE locality spec" }
+ end do
+ do concurrent (i=1:5) reduce(+:f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" }
+ end do
+ do concurrent (i=1:5) reduce(+:g(2)[1]) ! { dg-error "Expected variable name in REDUCE locality spec" }
+ end do
+ end subroutine test_c1131
+
+ subroutine test_c1132()
+ logical :: l1, l2, l3, l4
+ integer :: i, int1
+ real :: r1
+ complex :: c1, c2, c3
+ character(len=10) :: str1, str2, str3, str4
+
+ ! C1132 tests
+ do concurrent (i=1:5) &
+ reduce(+:l1) & ! { dg-error "Expected numeric type for 'l1' in REDUCE at \\(1\\), got LOGICAL" }
+ reduce(*:l2) & ! { dg-error "Expected numeric type for 'l2' in REDUCE at \\(1\\), got LOGICAL" }
+ reduce(max:l3) & ! { dg-error "Expected INTEGER, REAL or CHARACTER type for 'l3' in REDUCE with MIN/MAX at \\(1\\), got LOGICAL" }
+ reduce(iand:l4) ! { dg-error "Expected integer type for 'l4' in REDUCE with IAND/IOR/IEOR at \\(1\\), got LOGICAL" }
+ end do
+
+ do concurrent (i=1:5) &
+ reduce(*:str2) & ! { dg-error "Expected numeric type for 'str2' in REDUCE at \\(1\\), got CHARACTER" }
+ reduce(min:str3) & ! OK
+ reduce(max:str4) ! OK
+ end do
+
+ do concurrent (i=1:5) &
+ reduce(*:c2) & ! OK
+ reduce(max:c3) ! { dg-error "Expected INTEGER, REAL or CHARACTER type for 'c3' in REDUCE with MIN/MAX at \\(1\\), got COMPLEX" }
+ end do
+
+ end subroutine test_c1132
+
+end module m
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..08e1fb92e643d90fce8a7ef5fc55fbdd563ee222
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1" }
+program do_concurrent_local_init
+ implicit none
+ integer :: i, arr(10), temp
+ do concurrent (i = 1:10) local_init(temp) ! { dg-error "LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" }
+ temp = i
+ arr(i) = temp
+ end do
+ print *, arr
+end program do_concurrent_local_init
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0ee7a7e53b72f424d70e5f1f0d55385f5b3de882
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
@@ -0,0 +1,14 @@
+! { dg-additional-options "-Wunused-variable" }
+implicit none
+integer :: i, j, k, ll
+integer :: jj, kk, lll
+do , concurrent (i = 1:5) shared(j,jj) local(k,kk) local_init(ll,lll)
+ ! { dg-warning "Variable 'kk' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-1 }
+ ! { dg-warning "Variable 'll' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-2 }
+ ! { dg-warning "Variable 'jj' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-3 }
+ ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-4 }
+ j = 5
+ k = 7
+ lll = 8
+end do
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90
new file mode 100644
index 0000000000000000000000000000000000000000..47c71492107c4d7432df7da336144245a8552ef4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+program do_concurrent_multiple_reduce
+ implicit none
+ integer :: i, arr(10), sum, product
+ sum = 0
+ product = 1
+
+ do concurrent (i = 1:10) reduce(+:sum) reduce(*:product)
+ arr(i) = i
+ sum = sum + i
+ product = product * i
+ end do
+
+ print *, arr
+ print *, "Sum:", sum
+ print *, "Product:", product
+end program do_concurrent_multiple_reduce
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90
new file mode 100644
index 0000000000000000000000000000000000000000..83b9cdbc04fe0144d18f81077ee4c26c5d42ae9c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+program nested_do_concurrent
+ implicit none
+ integer :: i, j, x(10, 10)
+ integer :: total_sum
+
+ total_sum = 0
+
+ ! Outer loop remains DO CONCURRENT
+ do concurrent (i = 1:10)
+ ! Inner loop changed to regular DO loop
+ do j = 1, 10
+ x(i, j) = i * j
+ end do
+ end do
+
+ ! Separate loops for summation
+ do i = 1, 10
+ do j = 1, 10
+ total_sum = total_sum + x(i, j)
+ end do
+ end do
+
+ print *, "Total sum:", total_sum
+ print *, "Array:", x
+end program nested_do_concurrent
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5c55cdd83c76db6ecc418630e56922b4cfe6cc5b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+program do_concurrent_parser_errors
+ implicit none
+ integer :: i, x, b
+ do, concurrent (i=-3:4:2) default(none) shared(b) default(none) ! { dg-error "DEFAULT \\(NONE\\) specified more than once in DO CONCURRENT" }
+ b = i
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ do concurrent(i = 2 : 4) reduce(-:x) ! { dg-error "Expected reduction operator or function name" }
+ x = x - i
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ do concurrent(i = 2 : 4) reduce(+ x) ! { dg-error "Expected ':'" }
+ x = x + i
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ do concurrent(i = 2 : 4) reduce(+ , x) ! { dg-error "Expected ':'" }
+ x = x + i
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+ do concurrent(i = 2 : 4) reduction(+: x) ! { dg-error "Syntax error in DO statement" }
+ x = x + i
+ end do ! { dg-error "Expecting END PROGRAM statement" }
+end program do_concurrent_parser_errors
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ddf9626da7bd97fa3d39d985cec1f63a7ff7b675
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+program do_concurrent_reduce_max
+ implicit none
+ integer :: i, arr(10), max_val
+ max_val = 0
+
+ do concurrent (i = 1:10) reduce(max:max_val)
+ arr(i) = i * i
+ max_val = max(max_val, arr(i))
+ end do
+
+ print *, arr
+ print *, "Max value:", max_val
+end program do_concurrent_reduce_max
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1165e0c52432da9377b01febbfabf74225b33ff4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+program do_concurrent_reduce_sum
+ implicit none
+ integer :: i, arr(10), sum
+ sum = 0
+
+ do concurrent (i = 1:10) reduce(+:sum)
+ arr(i) = i
+ sum = sum + i
+ end do
+
+ print *, arr
+ print *, "Sum:", sum
+end program do_concurrent_reduce_sum
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6e3dd1c883d36f1a9b2978efbf7b3804cb179129
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+program do_concurrent_shared
+ implicit none
+ integer :: i, arr(10), sum
+ sum = 0
+
+ do concurrent (i = 1:10) shared(sum)
+ arr(i) = i
+ sum = sum + i
+ end do
+
+ print *, arr
+ print *, "Sum:", sum
+end program do_concurrent_shared
\ No newline at end of file