OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]
gcc/fortran/ChangeLog:
PR fortran/86470
* trans-expr.c (gfc_copy_class_to_class): Add unshare_expr.
* trans-openmp.c (gfc_is_polymorphic_nonptr,
gfc_is_unlimited_polymorphic_nonptr): New.
(gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): Handle
polymorphic scalars.
libgomp/ChangeLog:
PR fortran/86470
* testsuite/libgomp.fortran/class-firstprivate-1.f90: New test.
* testsuite/libgomp.fortran/class-firstprivate-2.f90: New test.
* testsuite/libgomp.fortran/class-firstprivate-3.f90: New test.
gcc/testsuite/ChangeLog:
PR fortran/86470
* gfortran.dg/gomp/class-firstprivate-1.f90: New test.
* gfortran.dg/gomp/class-firstprivate-2.f90: New test.
* gfortran.dg/gomp/class-firstprivate-3.f90: New test.
* gfortran.dg/gomp/class-firstprivate-4.f90: New test.
gcc/fortran/trans-expr.c | 2 +-
gcc/fortran/trans-openmp.c | 162 +++++++++-
.../gfortran.dg/gomp/class-firstprivate-1.f90 | 62 ++++
.../gfortran.dg/gomp/class-firstprivate-2.f90 | 54 ++++
.../gfortran.dg/gomp/class-firstprivate-3.f90 | 61 ++++
.../gfortran.dg/gomp/class-firstprivate-4.f90 | 44 +++
.../libgomp.fortran/class-firstprivate-1.f90 | 323 ++++++++++++++++++++
.../libgomp.fortran/class-firstprivate-2.f90 | 334 +++++++++++++++++++++
.../libgomp.fortran/class-firstprivate-3.f90 | 334 +++++++++++++++++++++
9 files changed, 1374 insertions(+), 2 deletions(-)
@@ -1524,7 +1524,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
{
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
- extcopy = build_call_vec (fcn_type, fcn, args);
+ extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
tmp = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len)));
@@ -360,6 +360,39 @@ gfc_has_alloc_comps (tree type, tree decl)
return false;
}
+/* Return true if TYPE is polymorphic but not with pointer attribute. */
+
+static bool
+gfc_is_polymorphic_nonptr (tree type)
+{
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ return GFC_CLASS_TYPE_P (type);
+}
+
+/* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
+ unlimited means also intrinsic types are handled and _len is used. */
+
+static bool
+gfc_is_unlimited_polymorphic_nonptr (tree type)
+{
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (!GFC_CLASS_TYPE_P (type))
+ return false;
+
+ tree field = TYPE_FIELDS (type); /* _data */
+ gcc_assert (field);
+ field = DECL_CHAIN (field); /* _vptr */
+ gcc_assert (field);
+ field = DECL_CHAIN (field);
+ if (!field)
+ return false;
+ gcc_assert (0 == strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))));
+ return true;
+}
+
+
/* Return true if DECL in private clause needs
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
bool
@@ -743,12 +776,88 @@ tree
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
{
tree type = TREE_TYPE (dest), ptr, size, call;
+ tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
tree cond, then_b, else_b;
stmtblock_t block, cond_block;
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
+ if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
+ decl_type
+ = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
+
+ if (gfc_is_polymorphic_nonptr (decl_type))
+ {
+ if (POINTER_TYPE_P (decl_type))
+ decl_type = TREE_TYPE (decl_type);
+ decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
+ if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
+ fatal_error (input_location,
+ "Sorry, polymorphic arrays not yet supported for "
+ "firstprivate");
+ tree src_len;
+ tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
+ tree src_data = gfc_class_data_get (unshare_expr (src));
+ tree dest_data = gfc_class_data_get (unshare_expr (dest));
+ bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
+
+ gfc_start_block (&block);
+ gfc_add_modify (&block, gfc_class_vptr_get (dest),
+ gfc_class_vptr_get (src));
+ gfc_init_block (&cond_block);
+
+ if (unlimited)
+ {
+ src_len = gfc_class_len_get (src);
+ gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
+ }
+
+ /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
+ size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
+ if (unlimited)
+ {
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ unshare_expr (src_len),
+ build_zero_cst (TREE_TYPE (src_len)));
+ cond = build3_loc (input_location, COND_EXPR, size_type_node, cond,
+ fold_convert (size_type_node,
+ unshare_expr (src_len)),
+ build_int_cst (size_type_node, 1));
+ size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ size, cond);
+ }
+
+ /* Malloc memory + call class->_vpt->_copy. */
+ call = builtin_decl_explicit (BUILT_IN_MALLOC);
+ call = build_call_expr_loc (input_location, call, 1, size);
+ gfc_add_modify (&cond_block, dest_data,
+ fold_convert (TREE_TYPE (dest_data), call));
+ gfc_add_expr_to_block (&cond_block,
+ gfc_copy_class_to_class (src, dest, nelems,
+ unlimited));
+
+ gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
+ if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
+ {
+ gfc_add_block_to_block (&block, &cond_block);
+ }
+ else
+ {
+ /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ src_data, null_pointer_node);
+ gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_finish_block (&cond_block),
+ fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ unshare_expr (dest_data), null_pointer_node)));
+ }
+ return gfc_finish_block (&block);
+ }
+
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
@@ -773,7 +882,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
gfc_init_block (&cond_block);
- gfc_add_modify (&cond_block, dest, src);
+ gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
@@ -1185,6 +1294,57 @@ tree
gfc_omp_clause_dtor (tree clause, tree decl)
{
tree type = TREE_TYPE (decl), tem;
+ tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
+
+ if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
+ decl_type
+ = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
+ if (gfc_is_polymorphic_nonptr (decl_type))
+ {
+ if (POINTER_TYPE_P (decl_type))
+ decl_type = TREE_TYPE (decl_type);
+ decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
+ if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
+ fatal_error (input_location,
+ "Sorry, polymorphic arrays not yet supported for "
+ "firstprivate");
+ stmtblock_t block, cond_block;
+ gfc_start_block (&block);
+ gfc_init_block (&cond_block);
+ tree final = gfc_class_vtab_final_get (decl);
+ tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ symbol_attribute attr = {};
+ tree data = gfc_class_data_get (decl);
+ tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
+
+ /* Call class->_vpt->_finalize + free. */
+ tree call = build_fold_indirect_ref (final);
+ call = build_call_expr_loc (input_location, call, 3,
+ gfc_build_addr_expr (NULL, desc),
+ size, boolean_false_node);
+ gfc_add_block_to_block (&cond_block, &se.pre);
+ gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
+ gfc_add_block_to_block (&cond_block, &se.post);
+ /* Create: if (_vtab && _final) <cond_block> */
+ tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ gfc_class_vptr_get (decl),
+ null_pointer_node);
+ tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ final, null_pointer_node);
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, cond, cond2);
+ gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_finish_block (&cond_block), NULL_TREE));
+ call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1, data);
+ gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+ return gfc_finish_block (&block);
+ }
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
new file mode 100644
@@ -0,0 +1,62 @@
+! { dg-do compile }
+! { dg-prune-output "compilation terminated." }
+!
+! FIRSTPRIVATE + class array
+!
+! For now: Expected to give "Sorry" for polymorphic arrays.
+!
+! Polymorphic arrays are tricky - at least if not allocatable, they become:
+! var.0 = var._data.data
+! which needs to be handled properly.
+!
+!
+program select_type_openmp
+ use iso_c_binding
+ !use omp_lib
+ implicit none
+ integer :: i
+ integer :: A(4)
+ type(c_ptr) :: B(4)
+
+ B = [(c_null_ptr, i=1,4)]
+ A = [1,2,3,4]
+ call sub(A, B)
+contains
+ subroutine sub(val1, val2)
+ class(*) :: val1(4)
+ type(c_ptr) :: val2(2:5)
+
+ !$OMP PARALLEL firstprivate(val2)
+ do i = 2, 5
+ if (c_associated (val2(i))) stop 123
+ end do
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [1, 2, 3, 4])) stop 4549
+ val1 = [32,6,48,28]
+ class default
+ stop 99
+ end select
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [32,6,48,28])) stop 4512
+ class default
+ stop 99
+ end select
+ !$OMP END PARALLEL
+
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [1, 2, 3, 4])) stop 454
+ class default
+ stop 99
+ end select
+ print *, "PASS!"
+ end subroutine
+end program select_type_openmp
new file mode 100644
@@ -0,0 +1,54 @@
+! { dg-do compile }
+! { dg-prune-output "compilation terminated." }
+!
+! FIRSTPRIVATE + class array
+!
+! For now: Expected to give "Sorry" for polymorphic arrays.
+!
+! Polymorphic arrays are tricky - at least if not allocatable, they become:
+! var.0 = var._data.data
+! which needs to be handled properly.
+!
+!
+program select_type_openmp
+ !use omp_lib
+ implicit none
+ class(*), allocatable :: B(:)
+
+ allocate(B, source=["abcdef","cdefi2"])
+ allocate(B, source=[1,2,3])
+ call sub(B)
+contains
+ subroutine sub(val2)
+ class(*), allocatable :: val2(:)
+
+ !$OMP PARALLEL firstprivate(val2) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
+ if (.not.allocated(val2)) stop 3
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 44
+ if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 4545
+ val2 = ["123456", "789ABC"]
+ class default
+ stop 991
+ end select
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 44
+ if (val2(1) /= "123456" .or. val2(2) /= "789ABC") stop 453
+ class default
+ stop 991
+ end select
+ !$OMP END PARALLEL
+
+ if (.not.allocated(val2)) stop 3
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 44
+ if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 456
+ class default
+ stop 991
+ end select
+ print *, "PASS!"
+ end subroutine
+end program select_type_openmp
new file mode 100644
@@ -0,0 +1,61 @@
+! { dg-do compile }
+! { dg-prune-output "compilation terminated." }
+!
+! FIRSTPRIVATE + class array
+!
+! For now: Expected to give "Sorry" for polymorphic arrays.
+!
+! Polymorphic arrays are tricky - at least if not allocatable, they become:
+! var.0 = var._data.data
+! which needs to be handled properly.
+!
+!
+program select_type_openmp
+ use iso_c_binding
+ !use omp_lib
+ implicit none
+ call sub
+contains
+ subroutine sub
+ integer :: i
+ class(*), allocatable :: val1(:)
+ type(c_ptr), allocatable :: val2(:)
+
+ allocate(val1, source=[1, 2, 3, 4])
+ allocate(val2(2:5))
+ val2 = c_null_ptr
+
+ !$OMP PARALLEL firstprivate(val2)
+ do i = 2, 5
+ if (c_associated (val2(i))) stop 123
+ end do
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [1, 2, 3, 4])) stop 4549
+ val1 = [32,6,48,28]
+ class default
+ stop 99
+ end select
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [32,6,48,28])) stop 4512
+ class default
+ stop 99
+ end select
+ !$OMP END PARALLEL
+
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [1, 2, 3, 4])) stop 454
+ class default
+ stop 99
+ end select
+ print *, "PASS!"
+ end subroutine
+end program select_type_openmp
new file mode 100644
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! { dg-prune-output "compilation terminated." }
+!
+! FIRSTPRIVATE + class array
+!
+! For now: Expected to give "Sorry" for polymorphic arrays.
+!
+! Polymorphic arrays are tricky - at least if not allocatable, they become:
+! var.0 = var._data.data
+! which needs to be handled properly.
+!
+!
+program select_type_openmp
+ use iso_c_binding
+ !use omp_lib
+ implicit none
+ integer x(4)
+ x = [1, 2, 3, 4]
+ call sub(x)
+ if (any (x /= [1,2,3,4])) stop 3
+contains
+ subroutine sub(val1)
+ integer :: i
+ class(*) :: val1(4)
+
+ !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 33
+ if (any (val1 /= [1, 2, 3, 4])) stop 4549
+ val1 = [32,6,48,28]
+ class default
+ stop 99
+ end select
+ select type (val1)
+ type is (integer)
+ if (size(val1) /= 4) stop 34
+ if (any (val1 /= [32,6,48,28])) stop 4512
+ class default
+ stop 98
+ end select
+ !$OMP END PARALLEL
+ end
+end
new file mode 100644
@@ -0,0 +1,323 @@
+! FIRSTPRIVATE: CLASS(*) + intrinsic types
+program select_type_openmp
+ implicit none
+ class(*), allocatable :: val1, val1a, val2, val3
+
+ call sub() ! local var
+
+ call sub2(val1, val1a, val2, val3) ! allocatable args
+
+ allocate(val1, source=7)
+ allocate(val1a, source=7)
+ allocate(val2, source="abcdef")
+ allocate(val3, source=4_"zyx4")
+ call sub3(val1, val1a, val2, val3) ! nonallocatable vars
+ deallocate(val1, val1a, val2, val3)
+contains
+subroutine sub()
+ class(*), allocatable :: val1, val1a, val2, val3
+ allocate(val1a, source=7)
+ allocate(val2, source="abcdef")
+ allocate(val3, source=4_"zyx4")
+
+ if (allocated(val1)) stop 1
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 2
+ if (.not.allocated(val1a)) stop 3
+ if (.not.allocated(val2)) stop 4
+ if (.not.allocated(val3)) stop 5
+
+ allocate(val1, source=7)
+
+ select type (val1)
+ type is (integer)
+ if (val1 /= 7) stop 6
+ val1 = 8
+ class default
+ stop 7
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 7) stop 8
+ val1a = 8
+ class default
+ stop 9
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 10
+ if (val2 /= "abcdef") stop 11
+ val2 = "123456"
+ class default
+ stop 12
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 13
+ if (val3 /= 4_"zyx4") stop 14
+ val3 = 4_"AbCd"
+ class default
+ stop 15
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 16
+ if (val3 /= 4_"AbCd") stop 17
+ val3 = 4_"1ab2"
+ class default
+ stop 18
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 19
+ if (val2 /= "123456") stop 20
+ val2 = "A2C4E6"
+ class default
+ stop 21
+ end select
+
+ select type (val1)
+ type is (integer)
+ if (val1 /= 8) stop 22
+ val1 = 9
+ class default
+ stop 23
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 8) stop 24
+ val1a = 9
+ class default
+ stop 25
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 26
+ if (.not. allocated(val1a)) stop 27
+ if (.not. allocated(val2)) stop 28
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 29
+ if (val2 /= "abcdef") stop 30
+ class default
+ stop 31
+ end select
+ select type (val3)
+ type is (character(len=*,kind=4))
+ if (len(val3) /= 4) stop 32
+ if (val3 /= 4_"zyx4") stop 33
+ class default
+ stop 34
+ end select
+ deallocate(val1a, val2, val3)
+end subroutine sub
+
+subroutine sub2(val1, val1a, val2, val3)
+ class(*), allocatable :: val1, val1a, val2, val3
+ optional :: val1a
+ allocate(val1a, source=7)
+ allocate(val2, source="abcdef")
+ allocate(val3, source=4_"zyx4")
+
+ if (allocated(val1)) stop 35
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 36
+ if (.not.allocated(val1a)) stop 37
+ if (.not.allocated(val2)) stop 38
+ if (.not.allocated(val3)) stop 39
+
+ allocate(val1, source=7)
+
+ select type (val1)
+ type is (integer)
+ if (val1 /= 7) stop 40
+ val1 = 8
+ class default
+ stop 41
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 7) stop 42
+ val1a = 8
+ class default
+ stop 43
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 44
+ if (val2 /= "abcdef") stop 45
+ val2 = "123456"
+ class default
+ stop 46
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 47
+ if (val3 /= 4_"zyx4") stop 48
+ val3 = "AbCd"
+ class default
+ stop 49
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 50
+ if (val3 /= 4_"AbCd") stop 51
+ val3 = 4_"1ab2"
+ class default
+ stop 52
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 53
+ if (val2 /= "123456") stop 54
+ val2 = "A2C4E6"
+ class default
+ stop 55
+ end select
+
+ select type (val1)
+ type is (integer)
+ if (val1 /= 8) stop 56
+ val1 = 9
+ class default
+ stop 57
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 8) stop 58
+ val1a = 9
+ class default
+ stop 59
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 60
+ if (.not. allocated(val1a)) stop 61
+ if (.not. allocated(val2)) stop 62
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 63
+ if (val2 /= "abcdef") stop 64
+ class default
+ stop 65
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 66
+ if (val3 /= 4_"zyx4") stop 67
+ val3 = 4_"AbCd"
+ class default
+ stop 68
+ end select
+ deallocate(val1a, val2, val3)
+end subroutine sub2
+
+subroutine sub3(val1, val1a, val2, val3)
+ class(*) :: val1, val1a, val2, val3
+ optional :: val1a
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ select type (val1)
+ type is (integer)
+ if (val1 /= 7) stop 69
+ val1 = 8
+ class default
+ stop 70
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 7) stop 71
+ val1a = 8
+ class default
+ stop 72
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 73
+ if (val2 /= "abcdef") stop 74
+ val2 = "123456"
+ class default
+ stop 75
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 76
+ if (val3 /= 4_"zyx4") stop 77
+ val3 = 4_"AbCd"
+ class default
+ stop 78
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 79
+ if (val3 /= 4_"AbCd") stop 80
+ val3 = 4_"1ab2"
+ class default
+ stop 81
+ end select
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 82
+ if (val2 /= "123456") stop 83
+ val2 = "A2C4E6"
+ class default
+ stop 84
+ end select
+
+ select type (val1)
+ type is (integer)
+ if (val1 /= 8) stop 85
+ val1 = 9
+ class default
+ stop 86
+ end select
+
+ select type (val1a)
+ type is (integer)
+ if (val1a /= 8) stop 87
+ val1a = 9
+ class default
+ stop 88
+ end select
+ !$OMP END PARALLEL
+
+ select type (val2)
+ type is (character(len=*))
+ if (len(val2) /= 6) stop 89
+ if (val2 /= "abcdef") stop 90
+ class default
+ stop 91
+ end select
+
+ select type (val3)
+ type is (character(len=*, kind=4))
+ if (len(val3) /= 4) stop 92
+ if (val3 /= 4_"zyx4") stop 93
+ val3 = 4_"AbCd"
+ class default
+ stop 94
+ end select
+end subroutine sub3
+end program select_type_openmp
new file mode 100644
@@ -0,0 +1,334 @@
+! FIRSTPRIVATE: CLASS(t) + derived types
+program select_type_openmp
+ implicit none
+ type t
+ end type t
+ type, extends(t) :: t_int
+ integer :: i
+ end type
+ type, extends(t) :: t_char1
+ character(len=:, kind=1), allocatable :: str
+ end type
+ type, extends(t) :: t_char4
+ character(len=:, kind=4), allocatable :: str
+ end type
+ class(t), allocatable :: val1, val1a, val2, val3
+
+ call sub() ! local var
+
+ call sub2(val1, val1a, val2, val3) ! allocatable args
+
+ allocate(val1, source=t_int(7))
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+ call sub3(val1, val1a, val2, val3) ! nonallocatable vars
+ deallocate(val1, val1a, val2, val3)
+contains
+subroutine sub()
+ class(t), allocatable :: val1, val1a, val2, val3
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+
+ if (allocated(val1)) stop 1
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 2
+ if (.not.allocated(val1a)) stop 3
+ if (.not.allocated(val2)) stop 4
+ if (.not.allocated(val3)) stop 5
+
+ allocate(val1, source=t_int(7))
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 6
+ val1%i = 8
+ class default
+ stop 7
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 8
+ val1a%i = 8
+ class default
+ stop 9
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 10
+ if (val2%str /= "abcdef") stop 11
+ val2%str = "123456"
+ class default
+ stop 12
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 13
+ if (val3%str /= 4_"zyx4") stop 14
+ val3%str = 4_"AbCd"
+ class default
+ stop 15
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 16
+ if (val3%str /= 4_"AbCd") stop 17
+ val3%str = 4_"1ab2"
+ class default
+ stop 18
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 19
+ if (val2%str /= "123456") stop 20
+ val2%str = "A2C4E6"
+ class default
+ stop 21
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 22
+ val1%i = 9
+ class default
+ stop 23
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 24
+ val1a%i = 9
+ class default
+ stop 25
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 26
+ if (.not. allocated(val1a)) stop 27
+ if (.not. allocated(val2)) stop 28
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 29
+ if (val2%str /= "abcdef") stop 30
+ class default
+ stop 31
+ end select
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 32
+ if (val3%str /= 4_"zyx4") stop 33
+ class default
+ stop 34
+ end select
+ deallocate(val1a,val2, val3)
+end subroutine sub
+
+subroutine sub2(val1, val1a, val2, val3)
+ class(t), allocatable :: val1, val1a, val2, val3
+ optional :: val1a
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+
+ if (allocated(val1)) stop 35
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 36
+ if (.not.allocated(val1a)) stop 37
+ if (.not.allocated(val2)) stop 38
+ if (.not.allocated(val3)) stop 39
+
+ allocate(val1, source=t_int(7))
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 40
+ val1%i = 8
+ class default
+ stop 41
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 42
+ val1a%i = 8
+ class default
+ stop 43
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 44
+ if (val2%str /= "abcdef") stop 45
+ val2%str = "123456"
+ class default
+ stop 46
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 47
+ if (val3%str /= 4_"zyx4") stop 48
+ val3%str = "AbCd"
+ class default
+ stop 49
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 50
+ if (val3%str /= 4_"AbCd") stop 51
+ val3%str = 4_"1ab2"
+ class default
+ stop 52
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 53
+ if (val2%str /= "123456") stop 54
+ val2%str = "A2C4E6"
+ class default
+ stop 55
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 56
+ val1%i = 9
+ class default
+ stop 57
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 58
+ val1a%i = 9
+ class default
+ stop 59
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 60
+ if (.not. allocated(val1a)) stop 61
+ if (.not. allocated(val2)) stop 62
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 63
+ if (val2%str /= "abcdef") stop 64
+ class default
+ stop 65
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 66
+ if (val3%str /= 4_"zyx4") stop 67
+ val3%str = 4_"AbCd"
+ class default
+ stop 68
+ end select
+ deallocate(val1a, val2, val3)
+end subroutine sub2
+
+subroutine sub3(val1, val1a, val2, val3)
+ class(t) :: val1, val1a, val2, val3
+ optional :: val1a
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 69
+ val1%i = 8
+ class default
+ stop 70
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 71
+ val1a%i = 8
+ class default
+ stop 72
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 73
+ if (val2%str /= "abcdef") stop 74
+ val2%str = "123456"
+ class default
+ stop 75
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 76
+ if (val3%str /= 4_"zyx4") stop 77
+ val3%str = 4_"AbCd"
+ class default
+ stop 78
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 79
+ if (val3%str /= 4_"AbCd") stop 80
+ val3%str = 4_"1ab2"
+ class default
+ stop 81
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 82
+ if (val2%str /= "123456") stop 83
+ val2%str = "A2C4E6"
+ class default
+ stop 84
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 85
+ val1%i = 9
+ class default
+ stop 86
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 87
+ val1a%i = 9
+ class default
+ stop 88
+ end select
+ !$OMP END PARALLEL
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 89
+ if (val2%str /= "abcdef") stop 90
+ class default
+ stop 91
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 92
+ if (val3%str /= 4_"zyx4") stop 93
+ val3%str = 4_"AbCd"
+ class default
+ stop 94
+ end select
+end subroutine sub3
+end program select_type_openmp
new file mode 100644
@@ -0,0 +1,334 @@
+! FIRSTPRIVATE: CLASS(*) + derived types
+program select_type_openmp
+ implicit none
+ type t
+ end type t
+ type, extends(t) :: t_int
+ integer :: i
+ end type
+ type, extends(t) :: t_char1
+ character(len=:, kind=1), allocatable :: str
+ end type
+ type, extends(t) :: t_char4
+ character(len=:, kind=4), allocatable :: str
+ end type
+ class(*), allocatable :: val1, val1a, val2, val3
+
+ call sub() ! local var
+
+ call sub2(val1, val1a, val2, val3) ! allocatable args
+
+ allocate(val1, source=t_int(7))
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+ call sub3(val1, val1a, val2, val3) ! nonallocatable vars
+ deallocate(val1, val1a, val2, val3)
+contains
+subroutine sub()
+ class(*), allocatable :: val1, val1a, val2, val3
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+
+ if (allocated(val1)) stop 1
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 2
+ if (.not.allocated(val1a)) stop 3
+ if (.not.allocated(val2)) stop 4
+ if (.not.allocated(val3)) stop 5
+
+ allocate(val1, source=t_int(7))
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 6
+ val1%i = 8
+ class default
+ stop 7
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 8
+ val1a%i = 8
+ class default
+ stop 9
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 10
+ if (val2%str /= "abcdef") stop 11
+ val2%str = "123456"
+ class default
+ stop 12
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 13
+ if (val3%str /= 4_"zyx4") stop 14
+ val3%str = 4_"AbCd"
+ class default
+ stop 15
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 16
+ if (val3%str /= 4_"AbCd") stop 17
+ val3%str = 4_"1ab2"
+ class default
+ stop 18
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 19
+ if (val2%str /= "123456") stop 20
+ val2%str = "A2C4E6"
+ class default
+ stop 21
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 22
+ val1%i = 9
+ class default
+ stop 23
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 24
+ val1a%i = 9
+ class default
+ stop 25
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 26
+ if (.not. allocated(val1a)) stop 27
+ if (.not. allocated(val2)) stop 28
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 29
+ if (val2%str /= "abcdef") stop 30
+ class default
+ stop 31
+ end select
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 32
+ if (val3%str /= 4_"zyx4") stop 33
+ class default
+ stop 34
+ end select
+ deallocate(val1a,val2, val3)
+end subroutine sub
+
+subroutine sub2(val1, val1a, val2, val3)
+ class(*), allocatable :: val1, val1a, val2, val3
+ optional :: val1a
+ allocate(val1a, source=t_int(7))
+ allocate(val2, source=t_char1("abcdef"))
+ allocate(val3, source=t_char4(4_"zyx4"))
+
+ if (allocated(val1)) stop 35
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ if (allocated(val1)) stop 36
+ if (.not.allocated(val1a)) stop 37
+ if (.not.allocated(val2)) stop 38
+ if (.not.allocated(val3)) stop 39
+
+ allocate(val1, source=t_int(7))
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 40
+ val1%i = 8
+ class default
+ stop 41
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 42
+ val1a%i = 8
+ class default
+ stop 43
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 44
+ if (val2%str /= "abcdef") stop 45
+ val2%str = "123456"
+ class default
+ stop 46
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 47
+ if (val3%str /= 4_"zyx4") stop 48
+ val3%str = "AbCd"
+ class default
+ stop 49
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 50
+ if (val3%str /= 4_"AbCd") stop 51
+ val3%str = 4_"1ab2"
+ class default
+ stop 52
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 53
+ if (val2%str /= "123456") stop 54
+ val2%str = "A2C4E6"
+ class default
+ stop 55
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 56
+ val1%i = 9
+ class default
+ stop 57
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 58
+ val1a%i = 9
+ class default
+ stop 59
+ end select
+ !$OMP END PARALLEL
+
+ if (allocated(val1)) stop 60
+ if (.not. allocated(val1a)) stop 61
+ if (.not. allocated(val2)) stop 62
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 63
+ if (val2%str /= "abcdef") stop 64
+ class default
+ stop 65
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 66
+ if (val3%str /= 4_"zyx4") stop 67
+ val3%str = 4_"AbCd"
+ class default
+ stop 68
+ end select
+ deallocate(val1a, val2, val3)
+end subroutine sub2
+
+subroutine sub3(val1, val1a, val2, val3)
+ class(*) :: val1, val1a, val2, val3
+ optional :: val1a
+
+ !$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 7) stop 69
+ val1%i = 8
+ class default
+ stop 70
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 7) stop 71
+ val1a%i = 8
+ class default
+ stop 72
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 73
+ if (val2%str /= "abcdef") stop 74
+ val2%str = "123456"
+ class default
+ stop 75
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 76
+ if (val3%str /= 4_"zyx4") stop 77
+ val3%str = 4_"AbCd"
+ class default
+ stop 78
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 79
+ if (val3%str /= 4_"AbCd") stop 80
+ val3%str = 4_"1ab2"
+ class default
+ stop 81
+ end select
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 82
+ if (val2%str /= "123456") stop 83
+ val2%str = "A2C4E6"
+ class default
+ stop 84
+ end select
+
+ select type (val1)
+ type is (t_int)
+ if (val1%i /= 8) stop 85
+ val1%i = 9
+ class default
+ stop 86
+ end select
+
+ select type (val1a)
+ type is (t_int)
+ if (val1a%i /= 8) stop 87
+ val1a%i = 9
+ class default
+ stop 88
+ end select
+ !$OMP END PARALLEL
+
+ select type (val2)
+ type is (t_char1)
+ if (len(val2%str) /= 6) stop 89
+ if (val2%str /= "abcdef") stop 90
+ class default
+ stop 91
+ end select
+
+ select type (val3)
+ type is (t_char4)
+ if (len(val3%str) /= 4) stop 92
+ if (val3%str /= 4_"zyx4") stop 93
+ val3%str = 4_"AbCd"
+ class default
+ stop 94
+ end select
+end subroutine sub3
+end program select_type_openmp