[PATCH] Fortran: Added support for locality specs in DO CONCURRENT (Fortran 2018/23)
Paul Richard Thomas
paul.richard.thomas@gmail.com
Mon Sep 23 08:26:52 GMT 2024
Hi Anuj,
In addition to Andre's remarks, could you please tell us, when you
resubmit, if this is a complete F2023 implementation of do concurrent. If
not, what is missing?
BTW Thanks for doing this. It was on my long term TODO list and is now
struck off :-)
Regards
Paul
On Mon, 23 Sept 2024 at 09:01, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Anuj,
>
> please check the code style of your patch using:
>
> contrib/check_GNU_style.py <your_patch>
>
> It reports several errors with line length and formatting.
>
> Could you also please specify the commit SHA your patch is supposed to
> apply
> to? At current mainline's HEAD it has several rejects which makes reviewing
> harder.
>
> And please attach the patch as plain text. It is html-encoded with several
> html-codes, for example a '>' is encoded as '>'. This makes it nearly
> impossible to apply.
>
> Therefore not good for mainline yet.
>
> - Andre
>
>
>
> On Sun, 22 Sep 2024 11:49:28 +0530
> Anuj Mohite <anujmohite001@gmail.com> 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
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://gcc.gnu.org/pipermail/fortran/attachments/20240923/5b910408/attachment-0001.htm>
More information about the Fortran
mailing list