This patch is essentially the one of PR101602, comment 6.
Thus, it has the same issues as that patch:
* LOCAL for derived-type variables with default
initalizers do not work (not initialized)
* LOCAL/LOCAL_INIT for assumed-shape arrays fails
(need some 'malloc'/'free' calls + some more other init).
I do not find the time to work on this, but I think it would
be very useful to finally have a working DO CONCURRENT in
GCC - and the missing bits should be really rare corner cases.
Thus, I went with the current version, but added error
diagnostic for the unsupported bits + updated the testcases.
(And add one for assumed-shape arrays).
OK for GCC 15 mainline?
Tobias
Fortran: Add code gen for do,concurrent's LOCAL/LOCAL_INIT [PR101602]
Implement LOCAL and LOCAL_INIT; we locally replace the tree declaration by
a local declaration of the outer variable. The 'local_init' then assigns
the value at the beginning of each loop iteration from the outer
declaration.
Note that the current implementation does not handle LOCAL with types that
have a default initializer and LOCAL/LOCAL_INIT for assumed-shape arrays;
this is diagnosed with a sorry error.
gcc/fortran/ChangeLog:
* resolve.cc (resolve_locality_spec): Remove 'sorry, unimplemented'.
* trans-stmt.cc (struct symbol_and_tree_t): New.
(gfc_trans_concurrent_locality_spec): New.
(gfc_trans_forall_1): Call it; update to handle local and local_init.
* trans-decl.cc (gfc_start_saved_local_decls,
gfc_stop_saved_local_decls): New; moved code from ...
(gfc_process_block_locals): ... here. Call it.
* trans.h (gfc_start_saved_local_decls,
gfc_stop_saved_local_decls): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/do_concurrent_8_f2023.f90: Update for removed 'sorry,
unimplemented'.
* gfortran.dg/do_concurrent_9.f90: Likewise.
* gfortran.dg/do_concurrent_all_clauses.f90: Likewise.
* gfortran.dg/do_concurrent_local_init.f90: Likewise.
* gfortran.dg/do_concurrent_locality_specs.f90: Likewise.
* gfortran.dg/do_concurrent_11.f90: New test.
* gfortran.dg/do_concurrent_12.f90: New test.
* gfortran.dg/do_concurrent_13.f90: New test.
* gfortran.dg/do_concurrent_14.f90: New test.
* gfortran.dg/do_concurrent_15.f90: New test.
gcc/fortran/resolve.cc | 7 -
gcc/fortran/trans-decl.cc | 35 ++--
gcc/fortran/trans-stmt.cc | 144 +++++++++++++-
gcc/fortran/trans.h | 2 +
gcc/testsuite/gfortran.dg/do_concurrent_11.f90 | 53 ++++++
gcc/testsuite/gfortran.dg/do_concurrent_12.f90 | 175 +++++++++++++++++
gcc/testsuite/gfortran.dg/do_concurrent_13.f90 | 211 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/do_concurrent_14.f90 | 176 +++++++++++++++++
gcc/testsuite/gfortran.dg/do_concurrent_15.f90 | 20 ++
.../gfortran.dg/do_concurrent_8_f2023.f90 | 4 +-
gcc/testsuite/gfortran.dg/do_concurrent_9.f90 | 2 +-
.../gfortran.dg/do_concurrent_all_clauses.f90 | 1 -
.../gfortran.dg/do_concurrent_local_init.f90 | 4 +-
.../gfortran.dg/do_concurrent_locality_specs.f90 | 3 +-
14 files changed, 807 insertions(+), 30 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cb3658917ef..cdf043b6411 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8422,13 +8422,6 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
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
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 8dd1c93dbdf..9087221dabb 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -8361,23 +8361,17 @@ gfc_generate_block_data (gfc_namespace * ns)
rest_of_decl_compilation (decl, 1, 0);
}
-
-/* Process the local variables of a BLOCK construct. */
-
void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_start_saved_local_decls ()
{
- tree decl;
-
+ gcc_checking_assert (current_function_decl != NULL_TREE);
saved_local_decls = NULL_TREE;
- has_coarray_vars_or_accessors = caf_accessor_head != NULL;
-
- generate_local_vars (ns);
-
- if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
- generate_coarray_init (ns);
+}
- decl = nreverse (saved_local_decls);
+void
+gfc_stop_saved_local_decls ()
+{
+ tree decl = nreverse (saved_local_decls);
while (decl)
{
tree next;
@@ -8390,5 +8384,20 @@ gfc_process_block_locals (gfc_namespace* ns)
saved_local_decls = NULL_TREE;
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ gfc_start_saved_local_decls ();
+ has_coarray_vars_or_accessors = caf_accessor_head != NULL;
+
+ generate_local_vars (ns);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
+ generate_coarray_init (ns);
+ gfc_stop_saved_local_decls ();
+}
+
#include "gt-fortran-trans-decl.h"
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f16e1e3b46e..94ecde096d5 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
-
+#define INCLUDE_VECTOR
#include "config.h"
#include "system.h"
#include "coretypes.h"
@@ -5093,6 +5093,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
}
}
+/* For saving the outer-variable data when doing
+ LOCAL and LOCAL_INIT substitution. */
+struct symbol_and_tree_t
+{
+ gfc_symbol *sym;
+ gfc_expr *value;
+ tree decl;
+ symbol_attribute attr;
+};
+
+/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
+ called twice, once with after_body=false - and then after the loop
+ body has been processed with after_body=true.
+
+ Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
+ locality specifiers of 'do concurrent' - and use it in the original
+ gfc_symbol. The declaration is then reset by after_body=true.
+
+ Variables in LOCAL_INIT are set in every loop iteration. */
+
+void
+gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
+ std::vector<symbol_and_tree_t> *saved_decls,
+ gfc_expr_list **locality_list)
+{
+ if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
+ return;
+
+ if (after_body)
+ {
+ for (unsigned i = 0; i < saved_decls->size (); i++)
+ {
+ (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
+ (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
+ (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
+ }
+ return;
+ }
+
+ gfc_expr_list *el;
+ int cnt = 0;
+ for (int i = 0; i <= 1; i++)
+ for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
+ el; el = el->next)
+ {
+ gfc_symbol *outer_sym = el->expr->symtree->n.sym;
+ if (!outer_sym->backend_decl)
+ outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
+ cnt++;
+ }
+ saved_decls->resize (cnt);
+
+ /* The variables have to be created in the scope of the loop body. */
+ if (!body->has_scope)
+ {
+ gcc_checking_assert (body->head == NULL_TREE);
+ gfc_start_block (body);
+ }
+ gfc_start_saved_local_decls ();
+
+ cnt = 0;
+ static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1);
+ for (int type = LOCALITY_LOCAL;
+ type <= LOCALITY_LOCAL_INIT; type++)
+ for (el = locality_list[type]; el; el = el->next)
+ {
+ gfc_symbol *sym = el->expr->symtree->n.sym;
+ (*saved_decls)[cnt].sym = sym;
+ (*saved_decls)[cnt].attr = sym->attr;
+ (*saved_decls)[cnt].value = sym->value;
+ (*saved_decls)[cnt].decl = sym->backend_decl;
+
+ if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
+ "is not yet supported",
+ type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
+ &el->expr->where, sym->name);
+ continue;
+ }
+
+ gfc_symbol outer_sym = *sym;
+
+ /* Create the inner local variable. */
+ sym->backend_decl = NULL;
+ sym->value = NULL;
+ sym->attr.save = SAVE_NONE;
+ sym->attr.value = 0;
+ sym->attr.dummy = 0;
+ sym->attr.optional = 0;
+
+ {
+ /* Slightly ugly hack for adding the decl via add_decl_as_local. */
+ gfc_symbol dummy_block_sym;
+ dummy_block_sym.attr.flavor = FL_LABEL;
+ gfc_symbol *saved_proc_name = sym->ns->proc_name;
+ sym->ns->proc_name = &dummy_block_sym;
+
+ gfc_get_symbol_decl (sym);
+ DECL_SOURCE_LOCATION (sym->backend_decl)
+ = gfc_get_location (&el->expr->where);
+
+ sym->ns->proc_name = saved_proc_name;
+ }
+
+ symbol_attribute attr = gfc_expr_attr (el->expr);
+ if (type == LOCALITY_LOCAL
+ && !attr.pointer
+ && sym->ts.type == BT_DERIVED
+ && gfc_has_default_initializer (sym->ts.u.derived))
+ /* Cf. PR fortran/ */
+ gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
+ " default initializer is not yet supported",
+ &el->expr->where, sym->name);
+ if (type == LOCALITY_LOCAL_INIT)
+ {
+ /* LOCAL_INIT: local_var = outer_var. */
+ gfc_symtree st = *el->expr->symtree;
+ st.n.sym = &outer_sym;
+ gfc_expr expr = *el->expr;
+ expr.symtree = &st;
+ tree t = (attr.pointer
+ ? gfc_trans_pointer_assignment (el->expr, &expr)
+ : gfc_trans_assignment (el->expr, &expr, false, false,
+ false, false));
+ gfc_add_expr_to_block (body, t);
+ }
+ cnt++;
+ }
+ gfc_stop_saved_local_decls ();
+}
+
/* FORALL and WHERE statements are really nasty, especially when you nest
them. All the rhs of a forall assignment must be evaluated before the
@@ -5348,9 +5480,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_init_block (&body);
cycle_label = gfc_build_label_decl (NULL_TREE);
code->cycle_label = cycle_label;
+
+ /* Handle LOCAL and LOCAL_INIT. */
+ std::vector<symbol_and_tree_t> saved_decls;
+ gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
+ code->ext.concur.locality);
+
+ /* Translate the body. */
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&body, tmp);
+ /* Reset locality variables. */
+ gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
+ code->ext.concur.locality);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 69c3d90bb23..63a566ada22 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -804,6 +804,8 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
tree rettype, int nargs, ...);
/* Process the local variable decls of a block construct. */
+void gfc_start_saved_local_decls ();
+void gfc_stop_saved_local_decls ();
void gfc_process_block_locals (gfc_namespace*);
/* Output initialization/clean-up code that was deferred. */
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_11.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_11.f90
new file mode 100644
index 00000000000..d4890a38338
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_11.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+
+module m
+implicit none
+contains
+subroutine sub(y,str)
+integer :: y, x, i
+character(len=5) :: str
+character(len=5) :: z = "abcde"
+logical :: error = .false.
+
+x = 5
+z = "12345"
+do concurrent (i = 1: 3) local_init(x) local_init(z) shared(error)default(none)
+ if (x /= 5) error = .true.
+ if (z /= "12345") error = .true.
+ x = 99
+ z = "XXXXX"
+end do
+if (x /= 5 .or. z /= "12345") stop 1
+if (error) stop 2
+
+do concurrent (i = 1: 3) local(y) local(str) shared(error) default(none)
+ y = 99
+ str = "XXXXX"
+end do
+if (y /= 42 .or. str /= "ABCDE") stop 3
+end
+end
+
+use m
+implicit none
+character(len=5) :: chars = "ABCDE"
+integer :: fourtytwo = 42
+call sub(fourtytwo, chars)
+end
+
+
+! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) x;" 2 "original" } }
+! { dg-final { scan-tree-dump-times " static character\\(kind=1\\) z\\\[1:5\\\] = .abcde.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " character\\(kind=1\\) z\\\[1:5\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) y;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " character\\(kind=1\\) str\\\[1:5\\\];" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times " x = 5;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\) &.12345.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times " x = x;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\)\\ &z, 5\\);" 1 "original" } }
+
+! { dg-final { scan-tree-dump-not " y = y;" "original" } }
+! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str, \\(void \\*\\)\\ &.XXXXX.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str," 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_12.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_12.f90
new file mode 100644
index 00000000000..8a2acfa81d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_12.f90
@@ -0,0 +1,175 @@
+! { dg-do compile }
+
+! Fails to compile because default initializers aren't supported.
+! cf. do_concurrent_14.f90 and PR fortran/101602 (comment 6)
+
+module m
+implicit none
+type t
+ integer :: y = 44
+ integer, pointer :: ptr(:) => null()
+end type t
+
+contains
+
+subroutine sub(x, y)
+ integer :: i
+ type(t) :: x, y(4)
+ type(t) :: a, b(3)
+ logical :: error = .false.
+ integer, target :: tgt(6)
+ integer, target :: tgt2(7)
+
+ x%y = 100
+ x%ptr => tgt
+ y(1)%y = 101
+ y(2)%y = 102
+ y(3)%y = 103
+ y(4)%y = 104
+ y(1)%ptr => tgt
+ y(2)%ptr => tgt
+ y(3)%ptr => tgt
+ y(4)%ptr => tgt
+
+ a%y = 105
+ a%ptr => tgt
+ b(1)%y = 106
+ b(2)%y = 107
+ b(3)%y = 108
+ b(1)%ptr => tgt
+ b(2)%ptr => tgt
+ b(3)%ptr => tgt
+
+ do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none)
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ error = .true.
+
+ x%y = 900
+ x%ptr => tgt
+ y(1)%y = 901
+ y(2)%y = 902
+ y(3)%y = 903
+ y(4)%y = 904
+ y(1)%ptr => tgt2
+ y(2)%ptr => tgt2
+ y(3)%ptr => tgt2
+ y(4)%ptr => tgt2
+
+ a%y = 905
+ a%ptr => tgt
+ b(1)%y = 906
+ b(2)%y = 907
+ b(3)%y = 908
+ b(1)%ptr => tgt2
+ b(2)%ptr => tgt2
+ b(3)%ptr => tgt2
+ end do
+
+ if (error) stop 1
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 2
+
+ do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2) default(none)
+! { dg-error "34: Sorry, LOCAL specifier at .1. for 'x' of derived type with default initializer is not yet supported" "" { target *-*-* } .-1 }
+! { dg-error "36: Sorry, LOCAL specifier at .1. for 'y' of derived type with default initializer is not yet supported" "" { target *-*-* } .-2 }
+! { dg-error "38: Sorry, LOCAL specifier at .1. for 'a' of derived type with default initializer is not yet supported" "" { target *-*-* } .-3 }
+! { dg-error "40: Sorry, LOCAL specifier at .1. for 'b' of derived type with default initializer is not yet supported" "" { target *-*-* } .-4 }
+
+ if (x%y /= 44) error = .true.
+ if (any(y(:)%y /= 44)) error = .true.
+ if (a%y /= 44) error = .true.
+ if (any (b(:)%y /= 44)) error = .true.
+
+ if (associated(x%ptr)) error = .true.
+ if (associated(y(1)%ptr)) error = .true.
+ if (associated(y(2)%ptr)) error = .true.
+ if (associated(y(3)%ptr)) error = .true.
+ if (associated(y(4)%ptr)) error = .true.
+ if (associated(a%ptr)) error = .true.
+ if (associated(b(1)%ptr)) error = .true.
+ if (associated(b(2)%ptr)) error = .true.
+ if (associated(b(3)%ptr)) error = .true.
+
+ x%y = 900
+ x%ptr => tgt
+ y(1)%y = 901
+ y(2)%y = 902
+ y(3)%y = 903
+ y(4)%y = 904
+ y(1)%ptr => tgt2
+ y(2)%ptr => tgt2
+ y(3)%ptr => tgt2
+ y(4)%ptr => tgt2
+
+ a%y = 905
+ a%ptr => tgt
+ b(1)%y = 906
+ b(2)%y = 907
+ b(3)%y = 908
+ b(1)%ptr => tgt2
+ b(2)%ptr => tgt2
+ b(3)%ptr => tgt2
+ end do
+
+ if (error) stop 3
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 4
+end
+end
+
+use m
+implicit none
+type(t) :: q, r(4)
+call sub(q,r)
+end
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_13.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_13.f90
new file mode 100644
index 00000000000..6545780020f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_13.f90
@@ -0,0 +1,211 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+
+module m
+implicit none
+type t
+ integer :: y = 44
+ integer, pointer :: ptr(:) => null()
+end type t
+
+contains
+
+subroutine sub(x, y)
+ integer :: i
+ type(t), pointer :: x, y(:)
+ type(t), pointer :: a, b(:)
+ logical :: error = .false.
+ integer, target :: tgt(6)
+ integer, target :: tgt2(7)
+
+ type(t), pointer :: x_saved
+ type(t), pointer :: y_saved(:)
+ type(t), pointer :: a_saved
+ type(t), pointer :: b_saved(:)
+
+ allocate(a, b(3))
+
+ x_saved => x
+ y_saved => y
+ a_saved => a
+ b_saved => b
+
+ x%y = 100
+ x%ptr => tgt
+ y(1)%y = 101
+ y(2)%y = 102
+ y(3)%y = 103
+ y(4)%y = 104
+ y(1)%ptr => tgt
+ y(2)%ptr => tgt
+ y(3)%ptr => tgt
+ y(4)%ptr => tgt
+
+ a%y = 105
+ a%ptr => tgt
+ b(1)%y = 106
+ b(2)%y = 107
+ b(3)%y = 108
+ b(1)%ptr => tgt
+ b(2)%ptr => tgt
+ b(3)%ptr => tgt
+
+ do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none)
+ if (.not.associated(x,x_saved)) error = .true.
+ if (.not.associated(y,y_saved)) error = .true.
+ if (.not.associated(a,a_saved)) error = .true.
+ if (.not.associated(b,b_saved)) error = .true.
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ error = .true.
+
+ if (i == 3) then
+ ! This is a hack - assuming no concurrency!
+ x%y = 900
+ y(1)%y = 901
+ a%y = 905
+ b(1)%y = 906
+ endif
+ x => null()
+ y => null()
+ a => null()
+ b => null()
+ end do
+
+ if (error) stop 1
+ if (.not.associated(x,x_saved)) stop 2
+ if (.not.associated(y,y_saved)) stop 3
+ if (.not.associated(a,a_saved)) stop 4
+ if (.not.associated(b,b_saved)) stop 5
+ ! Value a bit changed because of the hack above!
+ if (x%y /= 900 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 901 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 905 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 906 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 6
+
+ ! Reset
+ x%y = 100
+ y(1)%y = 101
+ a%y = 105
+ b(1)%y = 106
+
+ do concurrent (i = 1: 3) local(x,y,a,b) shared(error) default(none)
+ x => null()
+ y => null()
+ a => null()
+ b => null()
+ end do
+
+ if (.not.associated(x,x_saved)) stop 7
+ if (.not.associated(y,y_saved)) stop 8
+ if (.not.associated(a,a_saved)) stop 9
+ if (.not.associated(b,b_saved)) stop 10
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 11
+
+ do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none)
+ x => a_saved
+ y => b_saved
+ a => x_saved
+ b => y_saved
+ if (a%y /= 100 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 101 &
+ .or. b(2)%y /= 102 &
+ .or. b(3)%y /= 103 &
+ .or. b(4)%y /= 104 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt) &
+ .or. .not.associated (b(4)%ptr, tgt) &
+ .or. x%y /= 105 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 106 &
+ .or. y(2)%y /= 107 &
+ .or. y(3)%y /= 108 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt)) &
+ error = .true.
+ end do
+
+ if (.not.associated(x,x_saved)) stop 12
+ if (.not.associated(y,y_saved)) stop 13
+ if (.not.associated(a,a_saved)) stop 14
+ if (.not.associated(b,b_saved)) stop 15
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 16
+end
+end
+
+use m
+implicit none
+type(t), pointer :: q, r(:)
+allocate(q, r(4))
+call sub(q,r)
+end
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_14.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_14.f90
new file mode 100644
index 00000000000..c0a90ffb8f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_14.f90
@@ -0,0 +1,176 @@
+! { dg-do run }
+
+module m
+implicit none
+type t
+ integer :: y = 44
+ integer, pointer :: ptr(:) => null()
+end type t
+
+! No default initializers, cf. do_concurrent_12.f90
+! and PR fortran/101602 (comment 6)
+type t2
+ integer :: y
+ integer, pointer :: ptr(:)
+end type t2
+
+contains
+
+subroutine sub(x, y)
+ integer :: i
+ type(t) :: x, y(4)
+ type(t) :: a, b(3)
+ type(t2) :: x2, y2(4)
+ type(t2) :: a2, b2(3)
+ logical :: error = .false.
+ integer, target :: tgt(6)
+ integer, target :: tgt2(7)
+
+ x%y = 100
+ x%ptr => tgt
+ y(1)%y = 101
+ y(2)%y = 102
+ y(3)%y = 103
+ y(4)%y = 104
+ y(1)%ptr => tgt
+ y(2)%ptr => tgt
+ y(3)%ptr => tgt
+ y(4)%ptr => tgt
+
+ a%y = 105
+ a%ptr => tgt
+ b(1)%y = 106
+ b(2)%y = 107
+ b(3)%y = 108
+ b(1)%ptr => tgt
+ b(2)%ptr => tgt
+ b(3)%ptr => tgt
+
+ ! Copy values from 't' to associated 't2' variables
+ x2%y = x%y
+ x2%ptr => x%ptr
+ a2%y = a%y
+ a2%ptr => a%ptr
+ y2(:)%y = y(:)%y
+ do i = 1, size(y)
+ y2(i)%ptr => y(i)%ptr
+ end do
+ b2(:)%y = b(:)%y
+ do i = 1, size(b)
+ b2(i)%ptr => b(i)%ptr
+ end do
+
+ do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none)
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ error = .true.
+
+ x%y = 900
+ x%ptr => tgt
+ y(1)%y = 901
+ y(2)%y = 902
+ y(3)%y = 903
+ y(4)%y = 904
+ y(1)%ptr => tgt2
+ y(2)%ptr => tgt2
+ y(3)%ptr => tgt2
+ y(4)%ptr => tgt2
+
+ a%y = 905
+ a%ptr => tgt
+ b(1)%y = 906
+ b(2)%y = 907
+ b(3)%y = 908
+ b(1)%ptr => tgt2
+ b(2)%ptr => tgt2
+ b(3)%ptr => tgt2
+ end do
+
+ if (error) stop 1
+ if (x%y /= 100 &
+ .or. .not.associated (x%ptr, tgt) &
+ .or. y(1)%y /= 101 &
+ .or. y(2)%y /= 102 &
+ .or. y(3)%y /= 103 &
+ .or. y(4)%y /= 104 &
+ .or. .not.associated (y(1)%ptr, tgt) &
+ .or. .not.associated (y(2)%ptr, tgt) &
+ .or. .not.associated (y(3)%ptr, tgt) &
+ .or. .not.associated (y(4)%ptr, tgt) &
+ .or. a%y /= 105 &
+ .or. .not.associated (a%ptr, tgt) &
+ .or. b(1)%y /= 106 &
+ .or. b(2)%y /= 107 &
+ .or. b(3)%y /= 108 &
+ .or. .not.associated (b(1)%ptr, tgt) &
+ .or. .not.associated (b(2)%ptr, tgt) &
+ .or. .not.associated (b(3)%ptr, tgt)) &
+ stop 2
+
+ ! Use version without default initializers
+ do concurrent (i = 1: 3) local(x2,y2,a2,b2) shared(error,tgt,tgt2) default(none)
+ x2%y = 900
+ x2%ptr => tgt
+ y2(1)%y = 901
+ y2(2)%y = 902
+ y2(3)%y = 903
+ y2(4)%y = 904
+ y2(1)%ptr => tgt2
+ y2(2)%ptr => tgt2
+ y2(3)%ptr => tgt2
+ y2(4)%ptr => tgt2
+
+ a2%y = 905
+ a2%ptr => tgt
+ b2(1)%y = 906
+ b2(2)%y = 907
+ b2(3)%y = 908
+ b2(1)%ptr => tgt2
+ b2(2)%ptr => tgt2
+ b2(3)%ptr => tgt2
+ end do
+
+ if (error) stop 3
+ if (x2%y /= 100 &
+ .or. .not.associated (x2%ptr, tgt) &
+ .or. y2(1)%y /= 101 &
+ .or. y2(2)%y /= 102 &
+ .or. y2(3)%y /= 103 &
+ .or. y2(4)%y /= 104 &
+ .or. .not.associated (y2(1)%ptr, tgt) &
+ .or. .not.associated (y2(2)%ptr, tgt) &
+ .or. .not.associated (y2(3)%ptr, tgt) &
+ .or. .not.associated (y2(4)%ptr, tgt) &
+ .or. a2%y /= 105 &
+ .or. .not.associated (a2%ptr, tgt) &
+ .or. b2(1)%y /= 106 &
+ .or. b2(2)%y /= 107 &
+ .or. b2(3)%y /= 108 &
+ .or. .not.associated (b2(1)%ptr, tgt) &
+ .or. .not.associated (b2(2)%ptr, tgt) &
+ .or. .not.associated (b2(3)%ptr, tgt)) &
+ stop 4
+end
+end
+
+use m
+implicit none
+type(t) :: q, r(4)
+call sub(q,r)
+end
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_15.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_15.f90
new file mode 100644
index 00000000000..f0003c847e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_15.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+
+! Fails to compile because assumed-size arrays are not yet
+! handled with LOCAL / LOCAL_INIT, cf. PR fortran/101602 (comment 6)
+
+subroutine test_it(xx, yy)
+ implicit none
+ integer :: xx(:), yy(:,:)
+ integer :: i, sz1, sz2
+
+ sz1 = size(xx)
+ do , concurrent (i = 1 : sz1) local(xx) ! { dg-error "39: Sorry, LOCAL specifier at .1. for assumed-size array 'xx' is not yet supported" }
+ xx(i) = 1
+ end do
+
+ sz2 = size(yy,dim=1)
+ do , concurrent (i=1:sz2) local_init(yy) ! { dg-error "40: Sorry, LOCAL_INIT specifier at .1. for assumed-size array 'yy' is not yet supported" }
+ yy(i,:) = 1
+ end do
+end
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
index a99d81e4a5c..55eb97b6749 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90
@@ -8,10 +8,8 @@ program do_concurrent_complex
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)
@@ -20,4 +18,4 @@ program do_concurrent_complex
end do
end do
print *, sum, product
-end program do_concurrent_complex
\ No newline at end of file
+end program do_concurrent_complex
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90
index 98cef3ec588..9c1bca6687f 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90
@@ -6,7 +6,7 @@ program do_concurrent_default_none
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" }
+ do concurrent (i = 1:10) default(none) shared(x) local(y)
! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT \\(NONE\\)" "" { target *-*-* } .-1 }
x = x + i
y = i * 2
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
index 2e1c18cbf5c..0c8a6adcabd 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
@@ -11,7 +11,6 @@ program do_concurrent_all_clauses
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
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
index 08e1fb92e64..6c5e87ecc6e 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90
@@ -3,9 +3,9 @@
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" }
+ do concurrent (i = 1:10) local_init(temp)
temp = i
arr(i) = temp
end do
print *, arr
-end program do_concurrent_local_init
\ No newline at end of file
+end program do_concurrent_local_init
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
index 0ee7a7e53b7..ed3504efd86 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90
@@ -6,9 +6,8 @@ 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
+end
