[Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]

[Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 819 bytes --]

Belated follow-up to the patch from August ...
https://gcc.gnu.org/pipermail/gcc-patches/2020-August/552588.html

This patch handles CLASS variables in the FIRSTPRIVATE data-sharing
clause, including freeing the memory at the end.

Technically this patch fixes a regression as the ICE is new –
before the code was just rejected. It is also rather contained.

OK for mainline?

Tobias

PS: The dtor can be extended rather simply to support arrays, for
the copy_ctor, some scalarization loop is needed.
Todo: 'private', which has to allocate the
dynamic type and copy the default initialization
for this the dynamic type.

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf

[-- Attachment #2: omp-firstprivate-class.diff --]
[-- Type: text/x-patch, Size: 41417 bytes --]

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(-)

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 85c16d7f4c3..5389b9a4a37 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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)));
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 349df1cc346..7c25241a863 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
new file mode 100644
index 00000000000..0ff851db390
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
new file mode 100644
index 00000000000..354223741f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
new file mode 100644
index 00000000000..c83bf297511
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90
new file mode 100644
index 00000000000..237c6c535f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
new file mode 100644
index 00000000000..b77117ec611
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
new file mode 100644
index 00000000000..7528d32e8db
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
new file mode 100644
index 00000000000..a450fdee1ac
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
@@ -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

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]

[Tobias Burnus]

*PING*

(OpenMP patches: I note that the reduction + firstprivate→tofrom patch
is still being reviewed and that there are bunch of recently posted
patches by ChungLin + Julian which are also pending review.)
(There is also one patch (affinity + iterator) I still have to repost –
and will happen soon.)

Tobias

On 10.03.21 11:55, Tobias Burnus wrote:
> Belated follow-up to the patch from August ...
> https://gcc.gnu.org/pipermail/gcc-patches/2020-August/552588.html
>
> This patch handles CLASS variables in the FIRSTPRIVATE data-sharing
> clause, including freeing the memory at the end.
>
> Technically this patch fixes a regression as the ICE is new –
> before the code was just rejected. It is also rather contained.
>
> OK for mainline?
>
> Tobias
>
> PS: The dtor can be extended rather simply to support arrays, for
> the copy_ctor, some scalarization loop is needed.
> Todo: 'private', which has to allocate the
> dynamic type and copy the default initialization
> for this the dynamic type.
>
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]

[Jakub Jelinek]

On Wed, Mar 10, 2021 at 11:55:43AM +0100, Tobias Burnus wrote:
> --- a/gcc/fortran/trans-openmp.c
> +++ b/gcc/fortran/trans-openmp.c
> @@ -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))));

strcmp (...) == 0 instead please.

> +  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)));

Indentation, decl_type is indented by 4 spaces, but this line by tab (== 8 sp).

Otherwise LGTM, sorry for the delay.

	Jakub

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE (PR86470)

[Jakub Jelinek]

On Tue, Aug 25, 2020 at 12:50:46PM +0200, Tobias Burnus wrote:
> OK for mainline?

Generally, you know Fortran FE much more than I do, so just a few random
comments.

> --- a/gcc/fortran/trans-openmp.c
> +++ b/gcc/fortran/trans-openmp.c
> @@ -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))))

Is it safe to just look at the field names?  Shouldn't it at least also
test that the fields are DECL_ARTIFICIAL, or somehow else ensure that it
isn't a user derived type with _data and _vptr fields in it.

  type foo
    integer :: _data
    integer :: _vptr
    integer :: _len
  end type
  type(foo) :: a
  a%_data = 1
  a%_vptr = 2
  a%_len = 3
end
compiles just fine with -fallow-leading-underscore ...

> @@ -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))), '.'))

This seems very fragile, there are targets that use $ instead, other targets
use only underscores.
$ grep NO_DOT_IN_LABEL config/* config/*/* 2>/dev/null
config/vx-common.h:# define NO_DOT_IN_LABEL
config/mmix/mmix.h:#define NO_DOT_IN_LABEL
config/nvptx/nvptx.h:#define NO_DOT_IN_LABEL
config/xtensa/elf.h:#define NO_DOT_IN_LABEL
$ grep -w NO_DOLLAR_IN_LABEL config/* config/*/* 2>/dev/null
config/dragonfly.h:#undef NO_DOLLAR_IN_LABEL
config/elfos.h:#define NO_DOLLAR_IN_LABEL
config/freebsd.h:#undef NO_DOLLAR_IN_LABEL
config/vx-common.h:# undef NO_DOLLAR_IN_LABEL
config/alpha/alpha.h:#undef NO_DOLLAR_IN_LABEL
config/arm/aout.h:#ifndef NO_DOLLAR_IN_LABEL
config/arm/aout.h:#define NO_DOLLAR_IN_LABEL 1
config/mips/n32-elf.h:#define NO_DOLLAR_IN_LABEL
config/mmix/mmix.h:#define NO_DOLLAR_IN_LABEL
config/rs6000/rs6000.c:#ifdef NO_DOLLAR_IN_LABEL
config/rs6000/rs6000-protos.h:#ifdef NO_DOLLAR_IN_LABEL
config/rs6000/xcoff.h:#define NO_DOLLAR_IN_LABEL
config/tilegx/tilegx.h:#undef NO_DOLLAR_IN_LABEL
config/tilepro/tilepro.h:#undef NO_DOLLAR_IN_LABEL
config/xtensa/elf.h:#undef NO_DOLLAR_IN_LABEL

Couldn't it be recorded somewhere in DECL_LANG_SPECIFIC of the decl?

> +    fatal_error (input_location,
> +		 "Sorry, polymorphic arrays not yet supported for "
> +		 "firstprivate");

Shouldn't this be sorry ("...") instead?

> +      /* 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");

Likewise.

> +      /* Malloc memory + call class->_vpt->_copy.  */
> +      call = builtin_decl_explicit (BUILT_IN_MALLOC);

Is malloc what the FE uses elsewhere for it?  Will something free it
afterwards?

> +      if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
> +	{
> +	  gfc_add_block_to_block (&block, &cond_block);
> +	}

Formatting, one stmt shouldn't be wrapped into {}s.

	Jakub

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE (PR86470)

[Tobias Burnus]

Hi Andre,

On 8/31/20 12:55 PM, Andre Vehreschild wrote:
> +gfc_is_unlimited_polymorphic_nonptr (tree type)
> +  tree field = TYPE_FIELDS (type); /* _data */
> +  if (!field)
>
> ^^^ here you don't . So theoretically this routine could match a type which
> has a _len as its third field, but that is not a unlim-poly class. Maybe factor
> out the test from the above routine and unify with this one to reuse the test
> for a BT_CLASS?!

Granted. The reason was the code use:
if (polymophic)
   {
   ...
   if (unlimited_polymorphic)

Hence, I assumed that that check was already done, reducing
code size (but having less universality) and increasing
(cold-code) performance.

My new idea is to unify the two functions and add an
"bool only_unlimited" flag.

> Btw, I believe the first routine can be better replaced by:
>
> static bool
> gfc_is_polymorphic_nonptr (tree type)
> {
>    if (POINTER_TYPE_P (type))
>      type = TREE_TYPE (type);
>    return GFC_CLASS_TYPE_P (type);
> }

Maybe. However, when looking into the check for polymorphic
arrays, the DECL_LANG_SPECIFIC (and I think TYPE_LANG_SPECIFIC)
were present but contained only garbage. Thus, it might not work.
(I have to check.) – If it works, I will use your nicer suggestion.
If it doesn't work, I would go for my proposal above.
(Eventually, in a follow-up patch for polymorphic arrays, it has
to be fixed properly to avoid the following hack.)

> +  /* 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. */
> ...
> I totally agree that this is hackish and I don't like for that. But I can't
> come up with a better solution at the moment.

I think some changes at multiple places are needed to implement this
properly – but for the 'sorry' I did not want to do non-local changes;
for the real version, it should use some nicer code!

Thanks for the suggestions and review.

Tobias

PS: I want to first finish working on some other tasks before coming back
to this patch.

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE (PR86470)

[Andre Vehreschild]

Hi Tobias,

in (look for ^^^):

diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 063d4c145e2..705cdc7749f 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -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))))

^^^ here you are comparing the field - name

+    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)

^^^ here you don't . So theoretically this routine could match a type which
has a _len as its third field, but that is not a unlim-poly class. Maybe factor
out the test from the above routine and unify with this one to reuse the test
for a BT_CLASS?!

+    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;
+}
+
+

---------------------------------------------------------------------------------------------------------------

Btw, I believe the first routine can be better replaced by:

static bool
gfc_is_polymorphic_nonptr (tree type)
{
  if (POINTER_TYPE_P (type))
    type = TREE_TYPE (type);
  return GFC_CLASS_TYPE_P (type);
}

I have no better solution for learning whether a tree's type is unlimited poly
yet.


@@ -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");

I totally agree that this is hackish and I don't like for that. But I can't
come up with a better solution at the moment.

The remainder looks ok to me.

Regards,
	Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de

Re: [Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE (PR86470)

[Tobias Burnus]

*PING* — For this part 1/n patch series.

On 8/25/20 12:50 PM, Tobias Burnus wrote:
> 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

[Patch] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE (PR86470)

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1078 bytes --]

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

[-- Attachment #2: omp-firstprivate.diff --]
[-- Type: text/x-patch, Size: 37440 bytes --]

[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(-)

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 36ff9b5cbc6..b0c38e9f444 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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)));
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 063d4c145e2..705cdc7749f 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -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))
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
new file mode 100644
index 00000000000..0ff851db390
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
new file mode 100644
index 00000000000..354223741f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
new file mode 100644
index 00000000000..c83bf297511
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
new file mode 100644
index 00000000000..b77117ec611
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
new file mode 100644
index 00000000000..7528d32e8db
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
new file mode 100644
index 00000000000..a450fdee1ac
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
@@ -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