[Patch] 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): Handle polymorphic variables.
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.
gcc/fortran/trans-expr.c | 2 +-
gcc/fortran/trans-openmp.c | 126 +++++++++++++
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 | 62 ++++++
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 | 54 ++++++
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 | 61 ++++++
libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 | 323 +++++++++++++++++++++++++++++++
libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 | 334 +++++++++++++++++++++++++++++++++
libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 | 334 +++++++++++++++++++++++++++++++++
8 files changed, 1295 insertions(+), 1 deletion(-)
@@ -1451,7 +1451,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)));
@@ -355,6 +355,51 @@ 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);
+ if (TREE_CODE (type) != RECORD_TYPE)
+ return false;
+
+ tree field = TYPE_FIELDS (type);
+ if (!field || 0 != strcmp ("_data", IDENTIFIER_POINTER (DECL_NAME (field))))
+ return false;
+ field = DECL_CHAIN (field);
+ if (!field || 0 != strcmp ("_vptr", IDENTIFIER_POINTER (DECL_NAME (field))))
+ return false;
+
+ return true;
+}
+
+/* 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 (TREE_CODE (type) != RECORD_TYPE)
+ return false;
+
+ tree field = TYPE_FIELDS (type); /* _data */
+ if (!field)
+ return false;
+ field = DECL_CHAIN (field); /* _vptr */
+ if (!field)
+ return false;
+ field = DECL_CHAIN (field);
+ if (!field || 0 != strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))))
+ return false;
+
+ return true;
+}
+
+
/* Return true if DECL in private clause needs
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
bool
@@ -740,6 +785,87 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
+ /* TODO: implement support for polymorphic arrays; reject for now. */
+ /* Void arrays appear as var.0 = var._data.data. A bit hackish to
+ distinguish from 'type(c_ptr) :: var(5)' by scanning for '.';
+ this assumes that ASM_FORMAT_PRIVATE_NAME uses a '.', which most
+ systems do. */
+ if (TREE_CODE (type) == ARRAY_TYPE
+ && TREE_TYPE (type) == pvoid_type_node
+ && TREE_CODE (dest) == MEM_REF
+ && strchr (IDENTIFIER_POINTER (DECL_NAME (TREE_OPERAND (dest, 0))), '.'))
+ fatal_error (input_location,
+ "Sorry, polymorphic arrays not yet supported for "
+ "firstprivate");
+
+ if (gfc_is_polymorphic_nonptr (type))
+ {
+ 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);
+
+ /* var._data - _data is void* for scalars and descriptor for arrays. */
+ if (TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE)
+ fatal_error (input_location,
+ "Sorry, polymorphic arrays not yet supported for "
+ "firstprivate");
+
+ 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))
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,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
This patch adds support for polymorphic variables ("CLASS") to OpenMP's data-sharing clause FIRSTPRIVATE. While the patch should be okay, there is more follow-up work required, but one has to make a start :-) * PRIVATE – as used in the testcase of the PR is not yet supported, only FIRSTPRIVATE. * polymorphic arrays are not supported (see 'sorry'). – For nonallocatable arrays, the decl passed to the function does contain much information; the LANG_SPECIFIC is non-NULL its the pointer components contain garbage :-( – Handling noncharacter polymorphic arrays (hence: non-unlimited polymorphic) seems to be simpler; the current patch seems to work for some cases already, if the "sorry" is commented. * ... OK for mainline? Tobias PS: Supporting *map*ing of polymorphic variables is another matter, which is unfortunately even harder. ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter