On 1/7/25 12:06 PM, Jerry D wrote:
On 9/25/24 3:18 AM, Andre Vehreschild wrote:
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.
Interestingly, simply moving the gfc_forall_iterator back to where it
was before and changing all references to it to point to it I get a
clean build of gfortran, but several of the testcases now fail with a
segfault.
For example:
$ gfc -fcoarray=single do_concurrent_constraints.f90
f951: internal compiler error: Segmentation fault
0x22b9041 internal_error(char const*, ...)
../../trunk/gcc/diagnostic-global-context.cc:517
0xde4d6f crash_signal
../../trunk/gcc/toplev.cc:322
0x7053db parse_do_block
../../trunk/gcc/fortran/parse.cc:5414
0x7033c4 parse_executable
../../trunk/gcc/fortran/parse.cc:6396
0x7047ae parse_progunit
../../trunk/gcc/fortran/parse.cc:6803
0x704b58 parse_contained
../../trunk/gcc/fortran/parse.cc:6678
0x705b5c parse_module
../../trunk/gcc/fortran/parse.cc:7049
0x705f8c gfc_parse_file()
../../trunk/gcc/fortran/parse.cc:7351
0x75f69f gfc_be_parse_file
../../trunk/gcc/fortran/f95-lang.cc:241
In gdb it looks like the 'next' field in the iterator is pointing to
garbage when it ought to be NULL. I am looking around to see why that
is not getting initialized correctly or maybe this has uncovered
something more nasty.
Jerry
The attached patch is the latest clean build and test run I can come up
with. I completely cannot understand why moving the forall_iterator from
the sub-structure 'concur' back to where it was at the 'ext'
sub-structure of typedef struct gfc_code. 'ext' is a union. I suspected
there is an overlap going on there such that something is getting
overwritten or optimized away. I am unable to find the culprit.
Regression tested on x86_64. OK for trunk?
I will make sure the Changelog stuff is squared away. I also think I
will open a PR regarding the problem I described above.
Regards,
Jerry
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 8d31ddfcffb..e97693d54d9 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2899,7 +2899,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);
@@ -2959,7 +2959,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);
@@ -2972,7 +2972,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 3a3328d4450..8cbc67bb8d3 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5132,7 +5132,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. */
@@ -5142,7 +5142,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;
@@ -5158,7 +5158,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;
@@ -5410,7 +5410,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 aa495b5487e..5ea26944a90 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3109,6 +3109,16 @@ enum gfc_exec_op
EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH
};
+/* 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;
@@ -3129,6 +3139,20 @@ typedef struct gfc_code
{
gfc_actual_arglist *actual;
gfc_iterator *iterator;
+ gfc_open *open;
+ gfc_close *close;
+ gfc_filepos *filepos;
+ gfc_inquire *inquire;
+ gfc_wait *wait;
+ gfc_dt *dt;
+ struct gfc_code *which_construct;
+ gfc_entry_list *entry;
+ gfc_oacc_declare *oacc_declare;
+ gfc_omp_clauses *omp_clauses;
+ const char *omp_name;
+ gfc_omp_namelist *omp_namelist;
+ bool omp_bool;
+ int stop_code;
struct
{
@@ -3150,21 +3174,13 @@ typedef struct gfc_code
}
block;
- gfc_open *open;
- gfc_close *close;
- gfc_filepos *filepos;
- gfc_inquire *inquire;
- gfc_wait *wait;
- gfc_dt *dt;
- gfc_forall_iterator *forall_iterator;
- struct gfc_code *which_construct;
- int stop_code;
- gfc_entry_list *entry;
- gfc_oacc_declare *oacc_declare;
- gfc_omp_clauses *omp_clauses;
- const char *omp_name;
- gfc_omp_namelist *omp_namelist;
- bool omp_bool;
+ struct
+ {
+ gfc_forall_iterator *forall_iterator;
+ gfc_expr_list *locality[LOCALITY_NUM];
+ bool default_none;
+ }
+ concur;
}
ext; /* Points to additional structures required by statement */
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index e064cab5c80..c3c330520d6 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2568,7 +2568,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;
@@ -2618,7 +2618,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;
}
@@ -2641,7 +2641,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;
@@ -2703,9 +2703,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_forall_iterator *head = NULL;
+ 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"))
@@ -2716,6 +2727,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)
@@ -2731,14 +2994,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;
}
@@ -2749,6 +3024,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 f65449df9e2..fbecb174437 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5411,7 +5411,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 dab0c3af601..3e74a2e5088 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. */
@@ -8622,6 +8629,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
@@ -12079,7 +12424,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;
@@ -12129,7 +12474,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)
@@ -13961,12 +14306,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 0ee85c41292..509d28c23bd 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 d22ea8a4628..e7da8fea3b2 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -5165,7 +5165,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;
@@ -5185,7 +5185,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;
@@ -5446,7 +5446,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..98cef3ec588
--- /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
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..2e1c18cbf5c
--- /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)) ! { dg-error "Reference to impure function" }
+ end block
+ end do
+ print *, arr, sum, max_val
+end program do_concurrent_all_clauses
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..5c55cdd83c7
--- /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
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
