| Message ID | CAMw23nhZL+mxVLmxsfQFjbW_pzyJfNf-=BfwWij7GG+-be6FPg@mail.gmail.com |
|---|---|
| State | New |
| Headers | show |
| Series | Fortran: Added support for locality specs in DO CONCURRENT (Fortran 2018/23) | expand |
Hi all, as a background – Anuj, did this as part of his Google Summer of Code project (thanks!). As I looked as various drafts, I would be happy if someone else could have a look as well, as I probably start skipping over things and, hence, as miss potential issues … A bit hidden in the patch is a bug fix to allow 'concurrent' as loop variable name of a normal 'do' loop … Thanks, Tobias Anuj Mohite wrote: > gcc/fortran/ChangeLog: > > * dump-parse-tree.cc (show_code_node): Updated to use > c->ext.concur.forall_iterator instead of c->ext.forall_iterator. > Added support for dumping DO CONCURRENT locality specifiers. > * frontend-passes.cc (index_interchange, gfc_code_walker): Updated to > use c->ext.concur.forall_iterator instead of c->ext.forall_iterator. > * gfortran.h (enum locality_type): Added new enum for locality types > in DO CONCURRENT constructs. > * match.cc (match_simple_forall, gfc_match_forall): Updated to use > new_st.ext.concur.forall_iterator instead of new_st.ext.forall_iterator. > (gfc_match_do): Implemented support for matching DO CONCURRENT locality > specifiers (LOCAL, LOCAL_INIT, SHARED, DEFAULT(NONE), and REDUCE). > * parse.cc (parse_do_block): Updated to use > new_st.ext.concur.forall_iterator instead of new_st.ext.forall_iterator. > * resolve.cc: Added struct check_default_none_data. > (do_concur_locality_specs_f2023): New function to check compliance > with F2023's C1133 constraint for DO CONCURRENT. > (check_default_none_expr): New function to check DEFAULT(NONE) > compliance. > (resolve_locality_spec): New function to resolve locality specs. > (gfc_count_forall_iterators): Updated to use > code->ext.concur.forall_iterator. > (gfc_resolve_forall): Updated to use code->ext.concur.forall_iterator. > * st.cc (gfc_free_statement): Updated to free locality specifications > and use p->ext.concur.forall_iterator. > * trans-stmt.cc (gfc_trans_forall_1): Updated to use > code->ext.concur.forall_iterator. > > gcc/testsuite/ChangeLog: > > * gfortran.dg/do_concurrent_10.f90: New test for parsing DO CONCURRENT > with 'concurrent' as a variable name. > * gfortran.dg/do_concurrent_8_f2018.f90: New test for F2018 DO > CONCURRENT with nested loops and REDUCE clauses. > * gfortran.dg/do_concurrent_8_f2023.f90: New test for F2023 DO > CONCURRENT with nested loops and REDUCE clauses. > * gfortran.dg/do_concurrent_9.f90: New test for DO CONCURRENT with > DEFAULT(NONE) and locality specs. > * gfortran.dg/do_concurrent_all_clauses.f90: New test covering all DO > CONCURRENT clauses and their interactions. > * gfortran.dg/do_concurrent_basic.f90: New basic test for DO CONCURRENT > functionality. > * gfortran.dg/do_concurrent_constraints.f90: New test for constraints > on DO CONCURRENT locality specs. > * gfortran.dg/do_concurrent_local_init.f90: New test for LOCAL_INIT > clause in DO CONCURRENT. > * gfortran.dg/do_concurrent_locality_specs.f90: New test for DO > CONCURRENT with locality specs. > * gfortran.dg/do_concurrent_multiple_reduce.f90: New test for multiple > REDUCE clauses in DO CONCURRENT. > * gfortran.dg/do_concurrent_nested.f90: New test for nested DO > CONCURRENT loops. > * gfortran.dg/do_concurrent_parser.f90: New test for DO CONCURRENT > parser error handling. > * gfortran.dg/do_concurrent_reduce_max.f90: New test for REDUCE with > MAX operation in DO CONCURRENT. > * gfortran.dg/do_concurrent_reduce_sum.f90: New test for REDUCE with > sum operation in DO CONCURRENT. > * gfortran.dg/do_concurrent_shared.f90: New test for SHARED clause in > DO CONCURRENT. > > Signed-off-by: Anuj <anujmohite001@gmail.com> > --- > gcc/fortran/dump-parse-tree.cc | 113 +++++- > gcc/fortran/frontend-passes.cc | 8 +- > gcc/fortran/gfortran.h | 20 +- > gcc/fortran/match.cc | 286 +++++++++++++- > gcc/fortran/parse.cc | 2 +- > gcc/fortran/resolve.cc | 354 +++++++++++++++++- > gcc/fortran/st.cc | 5 +- > gcc/fortran/trans-stmt.cc | 6 +- > .../gfortran.dg/do_concurrent_10.f90 | 11 + > .../gfortran.dg/do_concurrent_8_f2018.f90 | 19 + > .../gfortran.dg/do_concurrent_8_f2023.f90 | 23 ++ > gcc/testsuite/gfortran.dg/do_concurrent_9.f90 | 15 + > .../gfortran.dg/do_concurrent_all_clauses.f90 | 26 ++ > .../gfortran.dg/do_concurrent_basic.f90 | 11 + > .../gfortran.dg/do_concurrent_constraints.f90 | 126 +++++++ > .../gfortran.dg/do_concurrent_local_init.f90 | 11 + > .../do_concurrent_locality_specs.f90 | 14 + > .../do_concurrent_multiple_reduce.f90 | 17 + > .../gfortran.dg/do_concurrent_nested.f90 | 26 ++ > .../gfortran.dg/do_concurrent_parser.f90 | 20 + > .../gfortran.dg/do_concurrent_reduce_max.f90 | 14 + > .../gfortran.dg/do_concurrent_reduce_sum.f90 | 14 + > .../gfortran.dg/do_concurrent_shared.f90 | 14 + > 23 files changed, 1134 insertions(+), 21 deletions(-) > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_10.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_9.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_nested.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_parser.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90 > create mode 100644 gcc/testsuite/gfortran.dg/do_concurrent_shared.f90 > > diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc > index 80aa8ef84e7..4cbd61c349e 100644 > --- a/gcc/fortran/dump-parse-tree.cc > +++ b/gcc/fortran/dump-parse-tree.cc > @@ -2830,7 +2830,7 @@ show_code_node (int level, gfc_code *c) > > case EXEC_FORALL: > fputs ("FORALL ", dumpfile); > - for (fa = c->ext.forall_iterator; fa; fa = fa->next) > + for (fa = c->ext.concur.forall_iterator; fa; fa = fa->next) > { > show_expr (fa->var); > fputc (' ', dumpfile); > @@ -2890,7 +2890,7 @@ show_code_node (int level, gfc_code *c) > > case EXEC_DO_CONCURRENT: > fputs ("DO CONCURRENT ", dumpfile); > - for (fa = c->ext.forall_iterator; fa; fa = fa->next) > + for (fa = c->ext.concur.forall_iterator; fa; fa = fa->next) > { > show_expr (fa->var); > fputc (' ', dumpfile); > @@ -2903,7 +2903,114 @@ show_code_node (int level, gfc_code *c) > if (fa->next != NULL) > fputc (',', dumpfile); > } > - show_expr (c->expr1); > + > + if (c->expr1 != NULL) > + { > + fputc (',', dumpfile); > + show_expr (c->expr1); > + } > + > + if (c->ext.concur.locality[LOCALITY_LOCAL]) > + { > + fputs (" LOCAL(", dumpfile); > + > + for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_LOCAL]; > + el; el = el->next) > + { > + show_expr (el->expr); > + if (el->next) > + fputc (',', dumpfile); > + } > + fputc (')', dumpfile); > + } > + > + if (c->ext.concur.locality[LOCALITY_LOCAL_INIT]) > + { > + fputs (" LOCAL_INIT(", dumpfile); > + for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_LOCAL_INIT]; > + el; el = el->next) > + { > + show_expr (el->expr); > + if (el->next) > + fputc (',', dumpfile); > + } > + fputc (')', dumpfile); > + } > + > + if (c->ext.concur.locality[LOCALITY_SHARED]) > + { > + fputs (" SHARED(", dumpfile); > + for (gfc_expr_list *el = c->ext.concur.locality[LOCALITY_SHARED]; > + el; el = el->next) > + { > + show_expr (el->expr); > + if (el->next) > + fputc (',', dumpfile); > + } > + fputc (')', dumpfile); > + } > + > + if (c->ext.concur.default_none) > + { > + fputs (" DEFAULT(NONE)", dumpfile); > + } > + > + if (c->ext.concur.locality[LOCALITY_REDUCE]) > + { > + gfc_expr_list *el = c->ext.concur.locality[LOCALITY_REDUCE]; > + while (el) > + { > + fputs (" REDUCE(", dumpfile); > + if (el->expr) > + { > + if (el->expr->expr_type == EXPR_FUNCTION) > + { > + const char *name; > + switch (el->expr->value.function.isym->id) > + { > + case GFC_ISYM_MIN: > + name = "MIN"; > + break; > + case GFC_ISYM_MAX: > + name = "MAX"; > + break; > + case GFC_ISYM_IAND: > + name = "IAND"; > + break; > + case GFC_ISYM_IOR: > + name = "IOR"; > + break; > + case GFC_ISYM_IEOR: > + name = "IEOR"; > + break; > + default: > + gcc_unreachable (); > + } > + fputs (name, dumpfile); > + } > + else > + show_expr (el->expr); > + } > + else > + { > + fputs ("(NULL)", dumpfile); > + } > + > + fputc (':', dumpfile); > + el = el->next; > + > + while (el && el->expr && el->expr->expr_type == EXPR_VARIABLE) > + { > + show_expr (el->expr); > + el = el->next; > + if (el && el->expr && el->expr->expr_type == EXPR_VARIABLE) > + fputc (',', dumpfile); > + } > + > + fputc (')', dumpfile); > + } > + } > + > ++show_level; > > show_code (level + 1, c->block->next); > diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc > index 3c06018fdbb..372fa8a8c76 100644 > --- a/gcc/fortran/frontend-passes.cc > +++ b/gcc/fortran/frontend-passes.cc > @@ -5171,7 +5171,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, > return 0; > > n_iter = 0; > - for (fa = co->ext.forall_iterator; fa; fa = fa->next) > + for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next) > n_iter ++; > > /* Nothing to reorder. */ > @@ -5181,7 +5181,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, > ind = XALLOCAVEC (ind_type, n_iter + 1); > > i = 0; > - for (fa = co->ext.forall_iterator; fa; fa = fa->next) > + for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next) > { > ind[i].sym = fa->var->symtree->n.sym; > ind[i].fa = fa; > @@ -5197,7 +5197,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, > qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp); > > /* Do the actual index interchange. */ > - co->ext.forall_iterator = fa = ind[0].fa; > + co->ext.concur.forall_iterator = fa = ind[0].fa; > for (i=1; i<n_iter; i++) > { > fa->next = ind[i].fa; > @@ -5449,7 +5449,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, > case EXEC_DO_CONCURRENT: > { > gfc_forall_iterator *fa; > - for (fa = co->ext.forall_iterator; fa; fa = fa->next) > + for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next) > { > WALK_SUBEXPR (fa->var); > WALK_SUBEXPR (fa->start); > diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h > index 36ed8eeac2d..c6aefb81a73 100644 > --- a/gcc/fortran/gfortran.h > +++ b/gcc/fortran/gfortran.h > @@ -3042,6 +3042,16 @@ enum gfc_exec_op > EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS > }; > > +/* Enum Definition for locality types. */ > +enum locality_type > +{ > + LOCALITY_LOCAL = 0, > + LOCALITY_LOCAL_INIT, > + LOCALITY_SHARED, > + LOCALITY_REDUCE, > + LOCALITY_NUM > +}; > + > typedef struct gfc_code > { > gfc_exec_op op; > @@ -3089,7 +3099,15 @@ typedef struct gfc_code > gfc_inquire *inquire; > gfc_wait *wait; > gfc_dt *dt; > - gfc_forall_iterator *forall_iterator; > + > + struct > + { > + gfc_forall_iterator *forall_iterator; > + gfc_expr_list *locality[LOCALITY_NUM]; > + bool default_none; > + } > + concur; > + > struct gfc_code *which_construct; > int stop_code; > gfc_entry_list *entry; > diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc > index 1851a8f94a5..8263b337df0 100644 > --- a/gcc/fortran/match.cc > +++ b/gcc/fortran/match.cc > @@ -2504,7 +2504,7 @@ match_simple_forall (void) > gfc_clear_new_st (); > new_st.op = EXEC_FORALL; > new_st.expr1 = mask; > - new_st.ext.forall_iterator = head; > + new_st.ext.concur.forall_iterator = head; > new_st.block = gfc_get_code (EXEC_FORALL); > new_st.block->next = c; > > @@ -2554,7 +2554,7 @@ gfc_match_forall (gfc_statement *st) > *st = ST_FORALL_BLOCK; > new_st.op = EXEC_FORALL; > new_st.expr1 = mask; > - new_st.ext.forall_iterator = head; > + new_st.ext.concur.forall_iterator = head; > return MATCH_YES; > } > > @@ -2577,7 +2577,7 @@ gfc_match_forall (gfc_statement *st) > gfc_clear_new_st (); > new_st.op = EXEC_FORALL; > new_st.expr1 = mask; > - new_st.ext.forall_iterator = head; > + new_st.ext.concur.forall_iterator = head; > new_st.block = gfc_get_code (EXEC_FORALL); > new_st.block->next = c; > > @@ -2639,9 +2639,20 @@ gfc_match_do (void) > if (gfc_match_parens () == MATCH_ERROR) > return MATCH_ERROR; > > + /* Handle DO CONCURRENT construct. */ > + > if (gfc_match (" concurrent") == MATCH_YES) > { > gfc_forall_iterator *head; > + gfc_expr_list *local = NULL; > + gfc_expr_list *local_tail = NULL; > + gfc_expr_list *local_init = NULL; > + gfc_expr_list *local_init_tail = NULL; > + gfc_expr_list *shared = NULL; > + gfc_expr_list *shared_tail = NULL; > + gfc_expr_list *reduce = NULL; > + gfc_expr_list *reduce_tail = NULL; > + bool default_none = false; > gfc_expr *mask; > > if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) > @@ -2652,6 +2663,258 @@ gfc_match_do (void) > head = NULL; > m = match_forall_header (&head, &mask); > > + if (m == MATCH_NO) > + goto match_do_loop; > + if (m == MATCH_ERROR) > + goto concurr_cleanup; > + > + while (true) > + { > + gfc_gobble_whitespace (); > + locus where = gfc_current_locus; > + > + if (gfc_match_eos () == MATCH_YES) > + break; > + > + else if (gfc_match ("local ( ") == MATCH_YES) > + { > + gfc_expr *e; > + while (true) > + { > + if (gfc_match_variable (&e, 0) != MATCH_YES) > + goto concurr_cleanup; > + > + if (local == NULL) > + local = local_tail = gfc_get_expr_list (); > + > + else > + { > + local_tail->next = gfc_get_expr_list (); > + local_tail = local_tail->next; > + } > + local_tail->expr = e; > + > + if (gfc_match_char (',') == MATCH_YES) > + continue; > + if (gfc_match_char (')') == MATCH_YES) > + break; > + goto concurr_cleanup; > + } > + } > + > + else if (gfc_match ("local_init ( ") == MATCH_YES) > + { > + gfc_expr *e; > + > + while (true) > + { > + if (gfc_match_variable (&e, 0) != MATCH_YES) > + goto concurr_cleanup; > + > + if (local_init == NULL) > + local_init = local_init_tail = gfc_get_expr_list (); > + > + else > + { > + local_init_tail->next = gfc_get_expr_list (); > + local_init_tail = local_init_tail->next; > + } > + local_init_tail->expr = e; > + > + if (gfc_match_char (',') == MATCH_YES) > + continue; > + if (gfc_match_char (')') == MATCH_YES) > + break; > + goto concurr_cleanup; > + } > + } > + > + else if (gfc_match ("shared ( ") == MATCH_YES) > + { > + gfc_expr *e; > + while (true) > + { > + if (gfc_match_variable (&e, 0) != MATCH_YES) > + goto concurr_cleanup; > + > + if (shared == NULL) > + shared = shared_tail = gfc_get_expr_list (); > + > + else > + { > + shared_tail->next = gfc_get_expr_list (); > + shared_tail = shared_tail->next; > + } > + shared_tail->expr = e; > + > + if (gfc_match_char (',') == MATCH_YES) > + continue; > + if (gfc_match_char (')') == MATCH_YES) > + break; > + goto concurr_cleanup; > + } > + } > + > + else if (gfc_match ("default ( none )") == MATCH_YES) > + { > + if (default_none) > + { > + gfc_error ("DEFAULT(NONE) specified more than once in DO " > + "CONCURRENT at %C"); > + goto concurr_cleanup; > + } > + default_none = true; > + } > + > + else if (gfc_match ("reduce ( ") == MATCH_YES) > + { > + gfc_expr *reduction_expr; > + where = gfc_current_locus; > + > + if (gfc_match_char ('+') == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_PLUS, > + NULL, NULL); > + > + else if (gfc_match_char ('*') == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_TIMES, > + NULL, NULL); > + > + else if (gfc_match (".and.") == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_AND, > + NULL, NULL); > + > + else if (gfc_match (".or.") == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_OR, > + NULL, NULL); > + > + else if (gfc_match (".eqv.") == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_EQV, > + NULL, NULL); > + > + else if (gfc_match (".neqv.") == MATCH_YES) > + reduction_expr = gfc_get_operator_expr (&where, > + INTRINSIC_NEQV, > + NULL, NULL); > + > + else if (gfc_match ("min") == MATCH_YES) > + { > + reduction_expr = gfc_get_expr (); > + reduction_expr->expr_type = EXPR_FUNCTION; > + reduction_expr->value.function.isym > + = gfc_intrinsic_function_by_id (GFC_ISYM_MIN); > + reduction_expr->where = where; > + } > + > + else if (gfc_match ("max") == MATCH_YES) > + { > + reduction_expr = gfc_get_expr (); > + reduction_expr->expr_type = EXPR_FUNCTION; > + reduction_expr->value.function.isym > + = gfc_intrinsic_function_by_id (GFC_ISYM_MAX); > + reduction_expr->where = where; > + } > + > + else if (gfc_match ("iand") == MATCH_YES) > + { > + reduction_expr = gfc_get_expr (); > + reduction_expr->expr_type = EXPR_FUNCTION; > + reduction_expr->value.function.isym > + = gfc_intrinsic_function_by_id (GFC_ISYM_IAND); > + reduction_expr->where = where; > + } > + > + else if (gfc_match ("ior") == MATCH_YES) > + { > + reduction_expr = gfc_get_expr (); > + reduction_expr->expr_type = EXPR_FUNCTION; > + reduction_expr->value.function.isym > + = gfc_intrinsic_function_by_id (GFC_ISYM_IOR); > + reduction_expr->where = where; > + } > + > + else if (gfc_match ("ieor") == MATCH_YES) > + { > + reduction_expr = gfc_get_expr (); > + reduction_expr->expr_type = EXPR_FUNCTION; > + reduction_expr->value.function.isym > + = gfc_intrinsic_function_by_id (GFC_ISYM_IEOR); > + reduction_expr->where = where; > + } > + > + else > + { > + gfc_error ("Expected reduction operator or function name " > + "at %C"); > + goto concurr_cleanup; > + } > + > + if (!reduce) > + { > + reduce = reduce_tail = gfc_get_expr_list (); > + } > + else > + { > + reduce_tail->next = gfc_get_expr_list (); > + reduce_tail = reduce_tail->next; > + } > + reduce_tail->expr = reduction_expr; > + > + gfc_gobble_whitespace (); > + > + if (gfc_match_char (':') != MATCH_YES) > + { > + gfc_error ("Expected %<:%> at %C"); > + goto concurr_cleanup; > + } > + > + while (true) > + { > + gfc_expr *reduction_expr; > + > + if (gfc_match_variable (&reduction_expr, 0) != MATCH_YES) > + { > + gfc_error ("Expected variable name in reduction list " > + "at %C"); > + goto concurr_cleanup; > + } > + > + if (reduce == NULL) > + reduce = reduce_tail = gfc_get_expr_list (); > + else > + { > + reduce_tail = reduce_tail->next = gfc_get_expr_list (); > + reduce_tail->expr = reduction_expr; > + } > + > + if (gfc_match_char (',') == MATCH_YES) > + continue; > + else if (gfc_match_char (')') == MATCH_YES) > + break; > + else > + { > + gfc_error ("Expected ',' or ')' in reduction list " > + "at %C"); > + goto concurr_cleanup; > + } > + } > + > + if (!gfc_notify_std (GFC_STD_F2023, "REDUCE locality spec at " > + "%L", &where)) > + goto concurr_cleanup; > + } > + else > + goto concurr_cleanup; > + > + if (!gfc_notify_std (GFC_STD_F2018, "Locality spec at %L", > + &gfc_current_locus)) > + goto concurr_cleanup; > + } > + > if (m == MATCH_NO) > return m; > if (m == MATCH_ERROR) > @@ -2667,14 +2930,26 @@ gfc_match_do (void) > new_st.label1 = label; > new_st.op = EXEC_DO_CONCURRENT; > new_st.expr1 = mask; > - new_st.ext.forall_iterator = head; > + new_st.ext.concur.forall_iterator = head; > + new_st.ext.concur.locality[LOCALITY_LOCAL] = local; > + new_st.ext.concur.locality[LOCALITY_LOCAL_INIT] = local_init; > + new_st.ext.concur.locality[LOCALITY_SHARED] = shared; > + new_st.ext.concur.locality[LOCALITY_REDUCE] = reduce; > + new_st.ext.concur.default_none = default_none; > > return MATCH_YES; > > concurr_cleanup: > - gfc_syntax_error (ST_DO); > gfc_free_expr (mask); > gfc_free_forall_iterator (head); > + gfc_free_expr_list (local); > + gfc_free_expr_list (local_init); > + gfc_free_expr_list (shared); > + gfc_free_expr_list (reduce); > + > + if (!gfc_error_check ()) > + gfc_syntax_error (ST_DO); > + > return MATCH_ERROR; > } > > @@ -2685,6 +2960,7 @@ concurr_cleanup: > goto done; > } > > +match_do_loop: > /* The abortive DO WHILE may have done something to the symbol > table, so we start over. */ > gfc_undo_symbols (); > diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc > index b28c8a94547..739d824e831 100644 > --- a/gcc/fortran/parse.cc > +++ b/gcc/fortran/parse.cc > @@ -5358,7 +5358,7 @@ parse_do_block (void) > if (do_op == EXEC_DO_CONCURRENT) > { > gfc_forall_iterator *fa; > - for (fa = new_st.ext.forall_iterator; fa; fa = fa->next) > + for (fa = new_st.ext.concur.forall_iterator; fa; fa = fa->next) > { > /* Apply unroll only to innermost loop (first control > variable). */ > diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc > index 4f4fafa4217..b0eed12afed 100644 > --- a/gcc/fortran/resolve.cc > +++ b/gcc/fortran/resolve.cc > @@ -54,6 +54,13 @@ code_stack; > > static code_stack *cs_base = NULL; > > +struct check_default_none_data > +{ > + gfc_code *code; > + hash_set<gfc_symbol *> *sym_hash; > + gfc_namespace *ns; > + bool default_none; > +}; > > /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ > > @@ -7794,6 +7801,344 @@ find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) > return false; > } > > +/* Check compliance with Fortran 2023's C1133 constraint for DO CONCURRENT > + This constraint specifies rules for variables in locality-specs. */ > + > +static int > +do_concur_locality_specs_f2023 (gfc_expr **expr, int *walk_subtrees, void *data) > +{ > + struct check_default_none_data *dt = (struct check_default_none_data *) data; > + > + if ((*expr)->expr_type == EXPR_VARIABLE) > + { > + gfc_symbol *sym = (*expr)->symtree->n.sym; > + for (gfc_expr_list *list = dt->code->ext.concur.locality[LOCALITY_LOCAL]; > + list; list = list->next) > + { > + if (list->expr->symtree->n.sym == sym) > + { > + gfc_error ("Variable %qs referenced in concurrent-header at %L " > + "must not appear in LOCAL locality-spec at %L", > + sym->name, &(*expr)->where, &list->expr->where); > + *walk_subtrees = 0; > + return 1; > + } > + } > + } > + > + *walk_subtrees = 1; > + return 0; > +} > + > +static int > +check_default_none_expr (gfc_expr **e, int *, void *data) > +{ > + struct check_default_none_data *d = (struct check_default_none_data*) data; > + > + if ((*e)->expr_type == EXPR_VARIABLE) > + { > + gfc_symbol *sym = (*e)->symtree->n.sym; > + > + if (d->sym_hash->contains (sym)) > + sym->mark = 1; > + > + else if (d->default_none) > + { > + gfc_namespace *ns2 = d->ns; > + while (ns2) > + { > + if (ns2 == sym->ns) > + break; > + ns2 = ns2->parent; > + } > + if (ns2 != NULL) > + { > + gfc_error ("Variable %qs at %L not specified in a locality spec " > + "of DO CONCURRENT at %L but required due to " > + "DEFAULT(NONE)", > + sym->name, &(*e)->where, &d->code->loc); > + d->sym_hash->add (sym); > + } > + } > + } > + return 0; > +} > + > +static void > +resolve_locality_spec (gfc_code *code, gfc_namespace *ns) > +{ > + struct check_default_none_data data; > + data.code = code; > + data.sym_hash = new hash_set<gfc_symbol *>; > + data.ns = ns; > + data.default_none = code->ext.concur.default_none; > + > + for (int locality = 0; locality < LOCALITY_NUM; locality++) > + { > + const char *name; > + switch (locality) > + { > + case LOCALITY_LOCAL: name = "LOCAL"; break; > + case LOCALITY_LOCAL_INIT: name = "LOCAL_INIT"; break; > + case LOCALITY_SHARED: name = "SHARED"; break; > + case LOCALITY_REDUCE: name = "REDUCE"; break; > + default: gcc_unreachable (); > + } > + > + for (gfc_expr_list *list = code->ext.concur.locality[locality]; list; > + list = list->next) > + { > + gfc_expr *expr = list->expr; > + > + if (locality == LOCALITY_REDUCE > + && (expr->expr_type == EXPR_FUNCTION > + || expr->expr_type == EXPR_OP)) > + continue; > + > + if (!gfc_resolve_expr (expr)) > + continue; > + > + if (expr->expr_type != EXPR_VARIABLE > + || expr->symtree->n.sym->attr.flavor != FL_VARIABLE > + || (expr->ref > + && (expr->ref->type != REF_ARRAY > + || expr->ref->u.ar.type != AR_FULL > + || expr->ref->next))) > + { > + gfc_error ("Expected variable name in %s locality spec at %L", > + name, &expr->where); > + continue; > + } > + > + gfc_symbol *sym = expr->symtree->n.sym; > + > + if (data.sym_hash->contains (sym)) > + { > + gfc_error ("Variable %qs at %L has already been specified in a " > + "locality-spec", sym->name, &expr->where); > + continue; > + } > + > + for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator; > + iter; iter = iter->next) > + { > + if (iter->var->symtree->n.sym == sym) > + { > + gfc_error ("Index variable %qs at %L cannot be specified in a" > + "locality-spec", sym->name, &expr->where); > + continue; > + } > + > + data.sym_hash->add (iter->var->symtree->n.sym); > + } > + > + if (locality == LOCALITY_LOCAL > + || locality == LOCALITY_LOCAL_INIT > + || locality == LOCALITY_REDUCE) > + { > + if (sym->attr.optional) > + gfc_error ("OPTIONAL attribute not permitted for %qs in %s " > + "locality-spec at %L", > + sym->name, name, &expr->where); > + > + if (sym->attr.dimension > + && sym->as > + && sym->as->type == AS_ASSUMED_SIZE) > + gfc_error ("Assumed-size array not permitted for %qs in %s " > + "locality-spec at %L", > + sym->name, name, &expr->where); > + > + gfc_check_vardef_context (expr, false, false, false, name); > + } > + > + if (locality == LOCALITY_LOCAL > + || locality == LOCALITY_LOCAL_INIT) > + { > + symbol_attribute attr = gfc_expr_attr (expr); > + > + if (attr.allocatable) > + gfc_error ("ALLOCATABLE attribute not permitted for %qs in %s " > + "locality-spec at %L", > + sym->name, name, &expr->where); > + > + else if (expr->ts.type == BT_CLASS && attr.dummy && !attr.pointer) > + gfc_error ("Nonpointer polymorphic dummy argument not permitted" > + " for %qs in %s locality-spec at %L", > + sym->name, name, &expr->where); > + > + else if (attr.codimension) > + gfc_error ("Coarray not permitted for %qs in %s locality-spec " > + "at %L", > + sym->name, name, &expr->where); > + > + else if (expr->ts.type == BT_DERIVED > + && gfc_is_finalizable (expr->ts.u.derived, NULL)) > + gfc_error ("Finalizable type not permitted for %qs in %s " > + "locality-spec at %L", > + sym->name, name, &expr->where); > + > + else if (gfc_has_ultimate_allocatable (expr)) > + gfc_error ("Type with ultimate allocatable component not " > + "permitted for %qs in %s locality-spec at %L", > + sym->name, name, &expr->where); > + } > + > + else if (locality == LOCALITY_REDUCE) > + { > + if (sym->attr.asynchronous) > + gfc_error ("ASYNCHRONOUS attribute not permitted for %qs in " > + "REDUCE locality-spec at %L", > + sym->name, &expr->where); > + if (sym->attr.volatile_) > + gfc_error ("VOLATILE attribute not permitted for %qs in REDUCE " > + "locality-spec at %L", sym->name, &expr->where); > + } > + > + data.sym_hash->add (sym); > + } > + > + if (locality == LOCALITY_LOCAL) > + { > + gcc_assert (locality == 0); > + > + for (gfc_forall_iterator *iter = code->ext.concur.forall_iterator; > + iter; iter = iter->next) > + { > + gfc_expr_walker (&iter->start, > + do_concur_locality_specs_f2023, > + &data); > + > + gfc_expr_walker (&iter->end, > + do_concur_locality_specs_f2023, > + &data); > + > + gfc_expr_walker (&iter->stride, > + do_concur_locality_specs_f2023, > + &data); > + } > + > + if (code->expr1) > + gfc_expr_walker (&code->expr1, > + do_concur_locality_specs_f2023, > + &data); > + } > + } > + > + gfc_expr *reduce_op = NULL; > + > + for (gfc_expr_list *list = code->ext.concur.locality[LOCALITY_REDUCE]; > + list; list = list->next) > + { > + gfc_expr *expr = list->expr; > + > + if (expr->expr_type != EXPR_VARIABLE) > + { > + reduce_op = expr; > + continue; > + } > + > + if (reduce_op->expr_type == EXPR_OP) > + { > + switch (reduce_op->value.op.op) > + { > + case INTRINSIC_PLUS: > + case INTRINSIC_TIMES: > + if (!gfc_numeric_ts (&expr->ts)) > + gfc_error ("Expected numeric type for %qs in REDUCE at %L, " > + "got %s", expr->symtree->n.sym->name, > + &expr->where, gfc_basic_typename (expr->ts.type)); > + break; > + case INTRINSIC_AND: > + case INTRINSIC_OR: > + case INTRINSIC_EQV: > + case INTRINSIC_NEQV: > + if (expr->ts.type != BT_LOGICAL) > + gfc_error ("Expected logical type for %qs in REDUCE at %L, " > + "got %qs", expr->symtree->n.sym->name, > + &expr->where, gfc_basic_typename (expr->ts.type)); > + break; > + default: > + gcc_unreachable (); > + } > + } > + > + else if (reduce_op->expr_type == EXPR_FUNCTION) > + { > + switch (reduce_op->value.function.isym->id) > + { > + case GFC_ISYM_MIN: > + case GFC_ISYM_MAX: > + if (expr->ts.type != BT_INTEGER > + && expr->ts.type != BT_REAL > + && expr->ts.type != BT_CHARACTER) > + gfc_error ("Expected INTEGER, REAL or CHARACTER type for %qs " > + "in REDUCE with MIN/MAX at %L, got %s", > + expr->symtree->n.sym->name, &expr->where, > + gfc_basic_typename (expr->ts.type)); > + break; > + case GFC_ISYM_IAND: > + case GFC_ISYM_IOR: > + case GFC_ISYM_IEOR: > + if (expr->ts.type != BT_INTEGER) > + gfc_error ("Expected integer type for %qs in REDUCE with " > + "IAND/IOR/IEOR at %L, got %s", > + expr->symtree->n.sym->name, &expr->where, > + gfc_basic_typename (expr->ts.type)); > + break; > + default: > + gcc_unreachable (); > + } > + } > + > + else > + gcc_unreachable (); > + } > + > + for (int locality = 0; locality < LOCALITY_NUM; locality++) > + { > + for (gfc_expr_list *list = code->ext.concur.locality[locality]; list; > + list = list->next) > + { > + if (list->expr->expr_type == EXPR_VARIABLE) > + list->expr->symtree->n.sym->mark = 0; > + } > + } > + > + gfc_code_walker (&code->block->next, gfc_dummy_code_callback, > + check_default_none_expr, &data); > + > + for (int locality = 0; locality < LOCALITY_NUM; locality++) > + { > + gfc_expr_list **plist = &code->ext.concur.locality[locality]; > + while (*plist) > + { > + gfc_expr *expr = (*plist)->expr; > + if (expr->expr_type == EXPR_VARIABLE) > + { > + gfc_symbol *sym = expr->symtree->n.sym; > + if (sym->mark == 0) > + { > + gfc_warning (OPT_Wunused_variable, "Variable %qs in " > + "locality-spec at %L is not used", > + sym->name, &expr->where); > + gfc_expr_list *tmp = *plist; > + *plist = (*plist)->next; > + gfc_free_expr (tmp->expr); > + free (tmp); > + continue; > + } > + } > + plist = &((*plist)->next); > + } > + } > + > + if (code->ext.concur.locality[LOCALITY_LOCAL] > + || code->ext.concur.locality[LOCALITY_LOCAL_INIT]) > + { > + gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for " > + "%<do concurrent%> constructs at %L", &code->loc); > + } > +} > > /* Resolve a list of FORALL iterators. The FORALL index-name is constrained > to be a scalar INTEGER variable. The subscripts and stride are scalar > @@ -11181,7 +11526,7 @@ gfc_count_forall_iterators (gfc_code *code) > max_iters = 0; > current_iters = 0; > > - for (fa = code->ext.forall_iterator; fa; fa = fa->next) > + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) > current_iters ++; > > code = code->block->next; > @@ -11231,7 +11576,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) > > /* The information about FORALL iterator, including FORALL indices start, end > and stride. An outer FORALL indice cannot appear in start, end or stride. */ > - for (fa = code->ext.forall_iterator; fa; fa = fa->next) > + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) > { > /* Fortran 20008: C738 (R753). */ > if (fa->var->ref && fa->var->ref->type == REF_ARRAY) > @@ -13021,12 +13366,15 @@ start: > > case EXEC_DO_CONCURRENT: > case EXEC_FORALL: > - resolve_forall_iterators (code->ext.forall_iterator); > + resolve_forall_iterators (code->ext.concur.forall_iterator); > > if (code->expr1 != NULL > && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) > gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " > "expression", &code->expr1->where); > + > + if (code->op == EXEC_DO_CONCURRENT) > + resolve_locality_spec (code, ns); > break; > > case EXEC_OACC_PARALLEL_LOOP: > diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc > index 0218d290782..63ef5ccb9d0 100644 > --- a/gcc/fortran/st.cc > +++ b/gcc/fortran/st.cc > @@ -189,8 +189,11 @@ gfc_free_statement (gfc_code *p) > break; > > case EXEC_DO_CONCURRENT: > + for (int i = 0; i < LOCALITY_NUM; i++) > + gfc_free_expr_list (p->ext.concur.locality[i]); > + gcc_fallthrough (); > case EXEC_FORALL: > - gfc_free_forall_iterator (p->ext.forall_iterator); > + gfc_free_forall_iterator (p->ext.concur.forall_iterator); > break; > > case EXEC_OACC_DECLARE: > diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc > index 93b633e212e..d5cef554a1e 100644 > --- a/gcc/fortran/trans-stmt.cc > +++ b/gcc/fortran/trans-stmt.cc > @@ -5063,7 +5063,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) > > n = 0; > /* Count the FORALL index number. */ > - for (fa = code->ext.forall_iterator; fa; fa = fa->next) > + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) > n++; > nvar = n; > > @@ -5083,7 +5083,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) > gfc_init_block (&block); > > n = 0; > - for (fa = code->ext.forall_iterator; fa; fa = fa->next) > + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) > { > gfc_symbol *sym = fa->var->symtree->n.sym; > > @@ -5344,7 +5344,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) > > done: > /* Restore the original index variables. */ > - for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) > + for (fa = code->ext.concur.forall_iterator, n = 0; fa; fa = fa->next, n++) > gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); > > /* Free the space for var, start, end, step, varexpr. */ > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_10.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_10.f90 > new file mode 100644 > index 00000000000..6bbeb3bc990 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_10.f90 > @@ -0,0 +1,11 @@ > +! { dg-do compile } > +! { dg-options "-std=f2018" } > + > +program do_concurrent_parsing > + implicit none > + integer :: concurrent, do > + do concurrent = 1, 5 > + end do > + do concurrent = 1, 5 > + end do > +end program do_concurrent_parsing > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90 > new file mode 100644 > index 00000000000..7449026dea8 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2018.f90 > @@ -0,0 +1,19 @@ > +! { dg-do compile } > +! { dg-options "-std=f2018" } > +program do_concurrent_complex > + implicit none > + integer :: i, j, k, sum, product > + integer, dimension(10,10,10) :: array > + sum = 0 > + product = 1 > + do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum) ! { dg-error "Fortran 2023: REDUCE locality spec" } > + do concurrent (j = 1:10) local(k) shared(product) reduce(*:product) ! { dg-error "Fortran 2023: REDUCE locality spec" } > + do concurrent (k = 1:10) > + array(i,j,k) = i * j * k > + sum = sum + array(i,j,k) > + product = product * array(i,j,k) > + end do > + end do ! { dg-error "Expecting END PROGRAM statement" } > + end do ! { dg-error "Expecting END PROGRAM statement" } > + print *, sum, product > +end program do_concurrent_complex > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 > new file mode 100644 > index 00000000000..a99d81e4a5c > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 > @@ -0,0 +1,23 @@ > +! { dg-do compile } > +! { dg-options "-std=gnu" } > +program do_concurrent_complex > + implicit none > + integer :: i, j, k, sum, product > + integer, dimension(10,10,10) :: array > + sum = 0 > + product = 1 > + do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum) > + ! { dg-error "Variable .sum. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 } > + ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 } > + do concurrent (j = 1:10) local(k) shared(product) reduce(*:product) > + ! { dg-error "Variable .product. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 } > + ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 } > + do concurrent (k = 1:10) > + array(i,j,k) = i * j * k > + sum = sum + array(i,j,k) > + product = product * array(i,j,k) > + end do > + end do > + end do > + print *, sum, product > +end program do_concurrent_complex > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 > new file mode 100644 > index 00000000000..86bc2b3ea0b > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 > @@ -0,0 +1,15 @@ > +! { dg-do compile } > +! { dg-options "-std=f2018" } > +program do_concurrent_default_none > + implicit none > + integer :: i, x, y, z > + x = 0 > + y = 0 > + z = 0 > + do concurrent (i = 1:10) default(none) shared(x) local(y) ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported" } > + ! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT\\(NONE\\)" "" { target *-*-* } .-1 } > + x = x + i > + y = i * 2 > + z = z + 1 ! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT\\(NONE\\)" } > + end do > +end program do_concurrent_default_none > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 > new file mode 100644 > index 00000000000..98e4b872839 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 > @@ -0,0 +1,26 @@ > +! { dg-do compile } > +program do_concurrent_all_clauses > + implicit none > + integer :: i, arr(10), sum, max_val, temp, squared > + sum = 0 > + max_val = 0 > + > + do concurrent (i = 1:10, i <= 8) & > + default(none) & > + local(temp) & > + shared(arr, squared, sum, max_val) & > + reduce(+:sum) & ! { dg-error "Variable 'sum' at \\(1\\) has already been specified in a locality-spec" } > + reduce(max:max_val) ! { dg-error "Variable 'max_val' at \\(1\\) has already been specified in a locality-spec" } > + ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported" "" { target *-*-* } .-1 } > + block > + integer :: temp2 > + temp = i * 2 > + temp2 = temp * 2 > + squared = i * i > + arr(i) = temp2 + squared > + sum = sum + arr(i) > + max_val = max(max_val, arr(i)) > + end block > + end do > + print *, arr, sum, max_val > +end program do_concurrent_all_clauses > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 > new file mode 100644 > index 00000000000..fe8723d48b4 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 > @@ -0,0 +1,11 @@ > +! { dg-do run } > +program basic_do_concurrent > + implicit none > + integer :: i, arr(10) > + > + do concurrent (i = 1:10) > + arr(i) = i > + end do > + > + print *, arr > +end program basic_do_concurrent > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90 > new file mode 100644 > index 00000000000..5716fc30b86 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_constraints.f90 > @@ -0,0 +1,126 @@ > +! { dg-do compile } > +! { dg-options "-fcoarray=single" } > + > +module m > + type t1 > + integer, allocatable :: x > + end type t1 > + > + type t2 > + type(t1), allocatable :: y > + end type t2 > + > + type, abstract :: abstract_type > + end type abstract_type > + > +contains > + subroutine test_c1130(a, b, c, d, e, f, g, h, j) > + integer, allocatable :: a > + integer, intent(in) :: b > + integer, optional :: c > + type(t1) :: d > + real :: e[*] > + integer :: f(*) > + type(t2) :: g > + class(abstract_type), pointer :: h > + class(abstract_type) :: j > + integer :: i > + > + ! C1130 tests > + do concurrent (i=1:5) local(a) ! { dg-error "ALLOCATABLE attribute not permitted for 'a' in LOCAL locality-spec" } > + end do > + do concurrent (i=1:5) local(b) ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(LOCAL\\) at" } > + end do > + do concurrent (i=1:5) local(c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in LOCAL locality-spec" } > + end do > + do concurrent (i=1:5) local(d) ! { dg-error "Type with ultimate allocatable component not permitted for 'd' in LOCAL locality-spec" } > + end do > + do concurrent (i=1:5) local(e) ! { dg-error "Expected variable name in LOCAL locality spec" } > + end do > + do concurrent (i=1:5) local(f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" } > + end do > + do concurrent (i=1:5) local(g) ! { dg-error "Type with ultimate allocatable component not permitted for 'g' in LOCAL locality-spec" } > + end do > + do concurrent (i=1:5) local(h) > + end do > + do concurrent (i=1:5) local(j) ! { dg-error "Nonpointer polymorphic dummy argument not permitted for 'j' in LOCAL locality-spec" } > + end do > + > + ! LOCAL_INIT tests > + do concurrent (i=1:5) local_init(a) ! { dg-error "ALLOCATABLE attribute not permitted for 'a' in LOCAL_INIT locality-spec" } > + end do > + do concurrent (i=1:5) local_init(b) ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(LOCAL_INIT\\) at" } > + end do > + do concurrent (i=1:5) local_init(c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in LOCAL_INIT locality-spec" } > + end do > + do concurrent (i=1:5) local_init(d) ! { dg-error "Type with ultimate allocatable component not permitted for 'd' in LOCAL_INIT locality-spec" } > + end do > + do concurrent (i=1:5) local_init(e) ! { dg-error "Expected variable name in LOCAL_INIT locality spec" } > + end do > + do concurrent (i=1:5) local_init(f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" } > + end do > + do concurrent (i=1:5) local_init(g) ! { dg-error "Type with ultimate allocatable component not permitted for 'g' in LOCAL_INIT locality-spec" } > + end do > + do concurrent (i=1:5) local_init(h) > + end do > + do concurrent (i=1:5) local_init(j) ! { dg-error "Nonpointer polymorphic dummy argument not permitted for 'j' in LOCAL_INIT locality-spec" } > + end do > + end subroutine test_c1130 > + > + subroutine test_c1131(a, b, c, d, e, f, g) > + integer, asynchronous :: a > + integer, intent(in) :: b > + integer, optional :: c > + integer, volatile :: d > + real :: e[*] > + integer :: f(*) > + real :: g(3)[*] > + integer :: i > + > + ! C1131 tests > + do concurrent (i=1:5) reduce(+:a) ! { dg-error "ASYNCHRONOUS attribute not permitted for 'a' in REDUCE locality-spec" } > + end do > + do concurrent (i=1:5) reduce(+:b) > + ! { dg-error "Dummy argument 'b' with INTENT\\(IN\\) in variable definition context \\(REDUCE\\)" "" { target *-*-* } .-1 } > + end do > + do concurrent (i=1:5) reduce(+:c) ! { dg-error "OPTIONAL attribute not permitted for 'c' in REDUCE locality-spec" } > + end do > + do concurrent (i=1:5) reduce(+:d) ! { dg-error "VOLATILE attribute not permitted for 'd' in REDUCE locality-spec" } > + end do > + do concurrent (i=1:5) reduce(+:e) ! { dg-error "Expected variable name in REDUCE locality spec" } > + end do > + do concurrent (i=1:5) reduce(+:f) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array 'f'" } > + end do > + do concurrent (i=1:5) reduce(+:g(2)[1]) ! { dg-error "Expected variable name in REDUCE locality spec" } > + end do > + end subroutine test_c1131 > + > + subroutine test_c1132() > + logical :: l1, l2, l3, l4 > + integer :: i, int1 > + real :: r1 > + complex :: c1, c2, c3 > + character(len=10) :: str1, str2, str3, str4 > + > + ! C1132 tests > + do concurrent (i=1:5) & > + reduce(+:l1) & ! { dg-error "Expected numeric type for 'l1' in REDUCE at \\(1\\), got LOGICAL" } > + reduce(*:l2) & ! { dg-error "Expected numeric type for 'l2' in REDUCE at \\(1\\), got LOGICAL" } > + reduce(max:l3) & ! { dg-error "Expected INTEGER, REAL or CHARACTER type for 'l3' in REDUCE with MIN/MAX at \\(1\\), got LOGICAL" } > + reduce(iand:l4) ! { dg-error "Expected integer type for 'l4' in REDUCE with IAND/IOR/IEOR at \\(1\\), got LOGICAL" } > + end do > + > + do concurrent (i=1:5) & > + reduce(*:str2) & ! { dg-error "Expected numeric type for 'str2' in REDUCE at \\(1\\), got CHARACTER" } > + reduce(min:str3) & ! OK > + reduce(max:str4) ! OK > + end do > + > + do concurrent (i=1:5) & > + reduce(*:c2) & ! OK > + reduce(max:c3) ! { dg-error "Expected INTEGER, REAL or CHARACTER type for 'c3' in REDUCE with MIN/MAX at \\(1\\), got COMPLEX" } > + end do > + > + end subroutine test_c1132 > + > +end module m > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 > new file mode 100644 > index 00000000000..08e1fb92e64 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 > @@ -0,0 +1,11 @@ > +! { dg-do compile } > +! { dg-options "-fmax-errors=1" } > +program do_concurrent_local_init > + implicit none > + integer :: i, arr(10), temp > + do concurrent (i = 1:10) local_init(temp) ! { dg-error "LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" } > + temp = i > + arr(i) = temp > + end do > + print *, arr > +end program do_concurrent_local_init > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 > new file mode 100644 > index 00000000000..0ee7a7e53b7 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 > @@ -0,0 +1,14 @@ > +! { dg-additional-options "-Wunused-variable" } > +implicit none > +integer :: i, j, k, ll > +integer :: jj, kk, lll > +do , concurrent (i = 1:5) shared(j,jj) local(k,kk) local_init(ll,lll) > + ! { dg-warning "Variable 'kk' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-1 } > + ! { dg-warning "Variable 'll' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-2 } > + ! { dg-warning "Variable 'jj' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-3 } > + ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-4 } > + j = 5 > + k = 7 > + lll = 8 > +end do > +end > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90 > new file mode 100644 > index 00000000000..47c71492107 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_multiple_reduce.f90 > @@ -0,0 +1,17 @@ > +! { dg-do compile } > +program do_concurrent_multiple_reduce > + implicit none > + integer :: i, arr(10), sum, product > + sum = 0 > + product = 1 > + > + do concurrent (i = 1:10) reduce(+:sum) reduce(*:product) > + arr(i) = i > + sum = sum + i > + product = product * i > + end do > + > + print *, arr > + print *, "Sum:", sum > + print *, "Product:", product > +end program do_concurrent_multiple_reduce > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90 > new file mode 100644 > index 00000000000..83b9cdbc04f > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_nested.f90 > @@ -0,0 +1,26 @@ > +! { dg-do compile } > +program nested_do_concurrent > + implicit none > + integer :: i, j, x(10, 10) > + integer :: total_sum > + > + total_sum = 0 > + > + ! Outer loop remains DO CONCURRENT > + do concurrent (i = 1:10) > + ! Inner loop changed to regular DO loop > + do j = 1, 10 > + x(i, j) = i * j > + end do > + end do > + > + ! Separate loops for summation > + do i = 1, 10 > + do j = 1, 10 > + total_sum = total_sum + x(i, j) > + end do > + end do > + > + print *, "Total sum:", total_sum > + print *, "Array:", x > +end program nested_do_concurrent > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90 > new file mode 100644 > index 00000000000..ec4ec6a7d0d > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_parser.f90 > @@ -0,0 +1,20 @@ > +! { dg-do compile } > +program do_concurrent_parser_errors > + implicit none > + integer :: i, x, b > + do, concurrent (i=-3:4:2) default(none) shared(b) default(none) ! { dg-error "DEFAULT\\(NONE\\) specified more than once in DO CONCURRENT" } > + b = i > + end do ! { dg-error "Expecting END PROGRAM statement" } > + do concurrent(i = 2 : 4) reduce(-:x) ! { dg-error "Expected reduction operator or function name" } > + x = x - i > + end do ! { dg-error "Expecting END PROGRAM statement" } > + do concurrent(i = 2 : 4) reduce(+ x) ! { dg-error "Expected ':'" } > + x = x + i > + end do ! { dg-error "Expecting END PROGRAM statement" } > + do concurrent(i = 2 : 4) reduce(+ , x) ! { dg-error "Expected ':'" } > + x = x + i > + end do ! { dg-error "Expecting END PROGRAM statement" } > + do concurrent(i = 2 : 4) reduction(+: x) ! { dg-error "Syntax error in DO statement" } > + x = x + i > + end do ! { dg-error "Expecting END PROGRAM statement" } > +end program do_concurrent_parser_errors > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90 > new file mode 100644 > index 00000000000..ddf9626da7b > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_max.f90 > @@ -0,0 +1,14 @@ > +! { dg-do compile } > +program do_concurrent_reduce_max > + implicit none > + integer :: i, arr(10), max_val > + max_val = 0 > + > + do concurrent (i = 1:10) reduce(max:max_val) > + arr(i) = i * i > + max_val = max(max_val, arr(i)) > + end do > + > + print *, arr > + print *, "Max value:", max_val > +end program do_concurrent_reduce_max > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90 > new file mode 100644 > index 00000000000..1165e0c5243 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_reduce_sum.f90 > @@ -0,0 +1,14 @@ > +! { dg-do compile } > +program do_concurrent_reduce_sum > + implicit none > + integer :: i, arr(10), sum > + sum = 0 > + > + do concurrent (i = 1:10) reduce(+:sum) > + arr(i) = i > + sum = sum + i > + end do > + > + print *, arr > + print *, "Sum:", sum > +end program do_concurrent_reduce_sum > \ No newline at end of file > diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90 > new file mode 100644 > index 00000000000..6e3dd1c883d > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/do_concurrent_shared.f90 > @@ -0,0 +1,14 @@ > +! { dg-do compile } > +program do_concurrent_shared > + implicit none > + integer :: i, arr(10), sum > + sum = 0 > + > + do concurrent (i = 1:10) shared(sum) > + arr(i) = i > + sum = sum + i > + end do > + > + print *, arr > + print *, "Sum:", sum > +end program do_concurrent_shared > \ No newline at end of file > -- > 2.43.0
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
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 >
Hi Paul, Am 23.09.24 um 10:26 schrieb Paul Richard Thomas: > 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? Regarding missing parts: still to do is actually privatizing (with or without initialization) for variables that are listed with 'local' and 'local_init'. Hence, code doing that currently fails after doing all required diagnostic with a 'sorry not yet implemented error'. [My feeling is that doing it in trans*.cc might make most sense, but it could be also done by adding at Fortran AST level (inserting a BLOCK + adding the variable there).] Otherwise, all parsing + diagnostic should work; 'default(none)' is diagnostics only and 'shared' doesn't do anything, except affecting 'default(none)' diagnostic. — 'reduce' will have a code gen effect, but only when going to real concurrency/parallel execution. * * * If you talk about unimplemented 'do concurrent' features in general, gfortran does not handle the forall/do-concurrent header with typespec (i.e. 'do concurrent (integer :: i = 1, 4)', cf. https://gcc.gnu.org/PR96255 [F2018 feature]. * * * In terms of true parallelization: * I was (since a while) thinking of having a -fdo-concurrent=<serial|omp-parallel|omp-target-parallel|openacc> compile-time flag to handle this. * OpenMP 6.0 (added I think in Technical Report (TR) 13, which was released Aug 1, 2024) now supports '!$omp loop' on 'do concurrent' Either variant would then use the new locality spec (F2018/F2023 and new in gfortran) and hook into the existing OpenMP/OpenACC handling. – '!$omp loop' and -fdo-concurrent=omp-parallel are in any case easier than 'omp-target-parallel' as the latter will run into issues related to data mapping or (potentially) atomic updates now having to be in sync with host atomic access. > BTW Thanks for doing this. It was on my long term TODO list and is now > struck off :-) Yes – and I have heard from others that do-concurrent actually being concurrent – or at least having having the new locality specs even if not run concurrently is a much missed feature. — That might be from a small bubble, but still those users wand to have it. And also Damian mentioned that he has a project what will use it. Also thanks from my side! Tobias
Hi Andre, Andre Vehreschild wrote: > 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. I just tried and here it applies cleanly on mainline, except that I get a bunch of: Hunk #1 succeeded at 2904 (offset 74 lines). style of warning, but those hunks still seem to end up at the proper play. > 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. I don't see this in my email program – and also when looking at https://gcc.gnu.org/pipermail/gcc-patches/2024-September/663534.html – I don't see any '>' – also not when looking at the the HTML attachment. > 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. Hmm, I only see errors related to tree dump, which seem to be okay: === ERROR type #1: there should be exactly one space between function name and parenthesis (7 error(s)) === gcc/fortran/dump-parse-tree.cc:2915:17: fputs (" LOCAL(", dumpfile); And the following is in the parser – and the spaces are mandatory here: === ERROR type #2: there should be no space before closing parenthesis (1 error(s)) === gcc/fortran/match.cc:2758:41: else if (gfc_match ("default ( none )") == MATCH_YES) I wonder what's the difference between our email readers. – Can you try the version from the mailing list archive? Cheers, Tobias
Hi Anuj, thanks for your work! I am unable to apply the patch, so I only looked at the testcases. Generally speaking, runtime tests should verify that they work as expected. Just printing a result does not. Use a comparison against an expected result and do e.g. STOP 123 on failure. Also, never use -std=gnu in the options; -std=gnu is the default, and its behavior may change any time. If you want to test something that is enabled at F2023, please use -std=f2023. Also, -std=gnu is meant to enable a GNU extension, but DO CONCURRENT is not an extension but defined in the Fortran standard. For details on my comments see below. Thanks, Harald Am 22.09.24 um 08:19 schrieb Anuj Mohite: > 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 ^^^ should this be 'do' instead of 'concurrent'? > + end do > +end program do_concurrent_parsing > 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" } ^^^ here you want -std=f2023 > +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_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 ^^^ this testcase does neither test the result, nor does it provide anything beyond existing tests. Consider dropping it. > 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 ^^^ please verify results! > +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 ^^^ please verify results! > +end program nested_do_concurrent > \ 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 ^^^ please verify results! > +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 ^^^ please verify results! > +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 ^^^ please verify results! > +end program do_concurrent_shared > \ No newline at end of file
Hi all, I have now downloaded the file at https://gcc.gnu.org/pipermail/gcc-patches/2024-September/663534.html (by copying it from the browser, not the source code to avoid '> This file had had to fix spurious line breaks like: @@ -5171,7 +5171,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, where the *... belongs to the previous line. the result of this conversion is the attached file. * * * Harald Anlauf wrote: > Generally speaking, runtime tests should verify that they work as > expected. There are currently only compile-time tests. [One might argue that some should be run-time tests, albeit the really interesting part only happens with local/local_init (currently not supported) – and with true concurrency in particular with 'reduce'.] [The interesting cases of 'local'/'local_init' there is a currently a 'sorry' while 'reduce' only becomes truly interesting if one goes parallel …] Tobias
Hi all, I finally managed to apply the fixed patch. It still had some stray line break so check_GNU_style.py wouldn't succeed. But with that fixed I agree to have only some nonsense bickering of the script. As to the patch (I have stripped large parts.): > 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; I am more than unhappy about that construct. Because every concurrent loop has a forall_iterator, but not every forall_iterator is a concurrent loop. I therefore propose to move the forall_iterator out of the struct and only have the concurrent specific elements in the struct. This would also reduce the changes significantly. I keep thinking about a "do concurrent " when all that is done is a regular "do " in Fortran just by having this concur in between. > + > struct gfc_code *which_construct; > int stop_code; > gfc_entry_list *entry; 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 <snipp> +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 *>; Memory new'ed here is never delete'd. Memory leak! + data.ns = ns; + data.default_none = code->ext.concur.default_none; + + for (int locality = 0; locality < LOCALITY_NUM; locality++) I haven't checked the tests, because Harald did so. Remark: How does this patch interplay with the UNSIGNED patch? I've seen some warnings about numeric types, where I suppose also UNSIGNED may be valid. I like to have my questions answered first before I ok this patch. Regards, Andre On Mon, 23 Sep 2024 22:55:51 +0200 Tobias Burnus <tburnus@baylibre.com> wrote: > Hi all, > > I have now downloaded the file at > https://gcc.gnu.org/pipermail/gcc-patches/2024-September/663534.html (by > copying it from the browser, not the source code to avoid '> > > This file had had to fix spurious line breaks like: > > @@ -5171,7 +5171,7 @@ index_interchange (gfc_code **c, int > *walk_subtrees ATTRIBUTE_UNUSED, > > where the *... belongs to the previous line. > > the result of this conversion is the attached file. > > * * * > > Harald Anlauf wrote: > > Generally speaking, runtime tests should verify that they work as > > expected. > > There are currently only compile-time tests. > > [One might argue that some should be run-time tests, albeit the really > interesting part only happens with local/local_init (currently not > supported) – and with true concurrency in particular with 'reduce'.] > > [The interesting cases of 'local'/'local_init' there is a currently a > 'sorry' while 'reduce' only becomes truly interesting if one goes > parallel …] > > Tobias
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
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