[PATCH] Fortran: Added support for locality specs in DO CONCURRENT (Fortran 2018/23)
Andre Vehreschild
vehre@gmx.de
Mon Sep 23 08:00:08 GMT 2024
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
More information about the Gcc-patches
mailing list