[PATCH] Fortran: Added support for locality specs in DO CONCURRENT (Fortran 2018/23)
Tobias Burnus
burnus@net-b.de
Mon Sep 23 07:43:01 GMT 2024
Hi all,
as a background – Anuj, did this as part of his Google Summer of Code
project (thanks!).
As I looked as various drafts, I would be happy if someone else could
have a look as well, as I probably start skipping over things and,
hence, as miss potential issues …
A bit hidden in the patch is a bug fix to allow 'concurrent' as loop
variable name of a normal 'do' loop …
Thanks,
Tobias
Anuj Mohite wrote:
> 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 <anujmohite001@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
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://gcc.gnu.org/pipermail/fortran/attachments/20240923/5c253441/attachment-0001.htm>
More information about the Fortran
mailing list