gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_code_node): Updated to use
c->ext.concur.forall_iterator instead of c->ext.forall_iterator.
Added support for dumping DO CONCURRENT locality specifiers.
* frontend-passes.cc (index_interchange, gfc_code_walker): Updated to
use c->ext.concur.forall_iterator instead of c->ext.forall_iterator.
* gfortran.h (enum locality_type): Added new enum for locality types
in DO CONCURRENT constructs.
* match.cc (match_simple_forall, gfc_match_forall): Updated to use
new_st.ext.concur.forall_iterator instead of new_st.ext.forall_iterator.
(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: 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 for parsing DO CONCURRENT
with 'concurrent' as a variable name.
* gfortran.dg/do_concurrent_8_f2018.f90: New test for F2018 DO
CONCURRENT with nested loops and REDUCE clauses.
* gfortran.dg/do_concurrent_8_f2023.f90: New test for F2023 DO
CONCURRENT with nested loops and REDUCE clauses.
* gfortran.dg/do_concurrent_9.f90: New test for DO CONCURRENT with
DEFAULT(NONE) and locality specs.
* gfortran.dg/do_concurrent_all_clauses.f90: New test covering all DO
CONCURRENT clauses and their interactions.
* gfortran.dg/do_concurrent_basic.f90: New basic test for DO CONCURRENT
functionality.
* gfortran.dg/do_concurrent_constraints.f90: New test for constraints
on DO CONCURRENT locality specs.
* gfortran.dg/do_concurrent_local_init.f90: New test for LOCAL_INIT
clause in DO CONCURRENT.
* gfortran.dg/do_concurrent_locality_specs.f90: New test for DO
CONCURRENT with locality specs.
* gfortran.dg/do_concurrent_multiple_reduce.f90: New test for multiple
REDUCE clauses in DO CONCURRENT.
* gfortran.dg/do_concurrent_nested.f90: New test for nested DO
CONCURRENT loops.
* gfortran.dg/do_concurrent_parser.f90: New test for DO CONCURRENT
parser error handling.
* gfortran.dg/do_concurrent_reduce_max.f90: New test for REDUCE with
MAX operation in DO CONCURRENT.
* gfortran.dg/do_concurrent_reduce_sum.f90: New test for REDUCE with
sum operation in DO CONCURRENT.
* gfortran.dg/do_concurrent_shared.f90: New test for SHARED clause in
DO CONCURRENT.
Signed-off-by: Anuj <anujmohite...@gmail.com>
---
gcc/fortran/dump-parse-tree.cc | 113 +++++-
gcc/fortran/frontend-passes.cc | 8 +-
gcc/fortran/gfortran.h | 20 +-
gcc/fortran/match.cc | 286 +++++++++++++-
gcc/fortran/parse.cc | 2 +-
gcc/fortran/resolve.cc | 354 +++++++++++++++++-
gcc/fortran/st.cc | 5 +-
gcc/fortran/trans-stmt.cc | 6 +-
.../gfortran.dg/do_concurrent_10.f90 | 11 +
.../gfortran.dg/do_concurrent_8_f2018.f90 | 19 +
.../gfortran.dg/do_concurrent_8_f2023.f90 | 23 ++
gcc/testsuite/gfortran.dg/do_concurrent_9.f90 | 15 +
.../gfortran.dg/do_concurrent_all_clauses.f90 | 26 ++
.../gfortran.dg/do_concurrent_basic.f90 | 11 +
.../gfortran.dg/do_concurrent_constraints.f90 | 126 +++++++
.../gfortran.dg/do_concurrent_local_init.f90 | 11 +
.../do_concurrent_locality_specs.f90 | 14 +
.../do_concurrent_multiple_reduce.f90 | 17 +
.../gfortran.dg/do_concurrent_nested.f90 | 26 ++
.../gfortran.dg/do_concurrent_parser.f90 | 20 +
.../gfortran.dg/do_concurrent_reduce_max.f90 | 14 +
.../gfortran.dg/do_concurrent_reduce_sum.f90 | 14 +
.../gfortran.dg/do_concurrent_shared.f90 | 14 +
23 files changed, 1134 insertions(+), 21 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_10.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_9.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_basic.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_nested.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_parser.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90
create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_shared.f90
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 80aa8ef84e7..4cbd61c349e 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2830,7 +2830,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);
@@ -2890,7 +2890,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);
@@ -2903,7 +2903,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 3c06018fdbb..372fa8a8c76 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5171,7 +5171,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. */
@@ -5181,7 +5181,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;
@@ -5197,7 +5197,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;
@@ -5449,7 +5449,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 36ed8eeac2d..c6aefb81a73 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3042,6 +3042,16 @@ enum gfc_exec_op
EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
+/* 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;
@@ -3089,7 +3099,15 @@ typedef struct gfc_code
gfc_inquire *inquire;
gfc_wait *wait;
gfc_dt *dt;
- gfc_forall_iterator *forall_iterator;
+
+ struct
+ {
+ gfc_forall_iterator *forall_iterator;
+ gfc_expr_list *locality[LOCALITY_NUM];
+ bool default_none;
+ }
+ concur;
+
struct gfc_code *which_construct;
int stop_code;
gfc_entry_list *entry;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 1851a8f94a5..8263b337df0 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2504,7 +2504,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;
@@ -2554,7 +2554,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;
}
@@ -2577,7 +2577,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;
@@ -2639,9 +2639,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_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"))
@@ -2652,6 +2663,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)
@@ -2667,14 +2930,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;
}
@@ -2685,6 +2960,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 b28c8a94547..739d824e831 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5358,7 +5358,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 4f4fafa4217..b0eed12afed 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. */
@@ -7794,6 +7801,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
@@ -11181,7 +11526,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;
@@ -11231,7 +11576,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)
@@ -13021,12 +13366,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 0218d290782..63ef5ccb9d0 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 93b633e212e..d5cef554a1e 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -5063,7 +5063,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;
@@ -5083,7 +5083,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;
@@ -5344,7 +5344,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 00000000000..6bbeb3bc990
--- /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 00000000000..7449026dea8
--- /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 00000000000..a99d81e4a5c
--- /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 00000000000..86bc2b3ea0b
--- /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
\ No newline at end of file
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 00000000000..98e4b872839
--- /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))
+ end block
+ end do
+ print *, arr, sum, max_val
+end program do_concurrent_all_clauses
\ No newline at end of file
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 00000000000..fe8723d48b4
--- /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 00000000000..5716fc30b86
--- /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 00000000000..08e1fb92e64
--- /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 00000000000..0ee7a7e53b7
--- /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 00000000000..47c71492107
--- /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 00000000000..83b9cdbc04f
--- /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 00000000000..ec4ec6a7d0d
--- /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
\ No newline at end of file
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 00000000000..ddf9626da7b
--- /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 00000000000..1165e0c5243
--- /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 00000000000..6e3dd1c883d
--- /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
--
2.43.0
