Fortran: fix TRANSFER with rank 1 unlimited polymorphic SOURCE [PR121263]

	PR fortran/121263

gcc/fortran/ChangeLog:

	* trans-intrinsic.cc (gfc_conv_intrinsic_transfer): For an
	unlimited polymorphic SOURCE to TRANSFER use saved descriptor
	if possible.

gcc/testsuite/ChangeLog:

	* gfortran.dg/transfer_class_5.f90: New test.

(cherry picked from commit 692281a38773a70ae795b3b594f0c0f8fd83e5ef)

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 1132b71bb15efcdc48553aa544fc86bbfba12320..f79d60957b2aa6a6291028c186164c913760dff8 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8513,7 +8513,12 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
                                       argse.string_length);
       else if (arg->expr->ts.type == BT_CLASS)
        {
-         class_ref = TREE_OPERAND (argse.expr, 0);
+         if (UNLIMITED_POLY (source_expr)
+             && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
+           class_ref = GFC_DECL_SAVED_DESCRIPTOR
+             (source_expr->symtree->n.sym->backend_decl);
+         else
+           class_ref = TREE_OPERAND (argse.expr, 0);
          tmp = gfc_class_vtab_size_get (class_ref);
          if (UNLIMITED_POLY (arg->expr))
            tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);

diff --git a/gcc/testsuite/gfortran.dg/transfer_class_5.f90 b/gcc/testsuite/gfortran.dg/transfer_class_5.f90
new file mode 100644 (file)
index 0000000..4ce5eb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_5.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+! PR fortran/121263 - fix TRANSFER with rank 1 unlimited polymorhpic
+!
+! Based on original testcase by Chris Cox.
+
+module stdlib_hashmap_wrappers
+  implicit none
+contains
+  subroutine set_rank_one_key_int( key, value )
+    integer, allocatable, intent(inout) :: key(:)
+    class(*), intent(in)                :: value(:)
+    key = transfer( value, key )
+  end subroutine
+
+  subroutine set_rank_one_key_cx ( key, value )
+    complex, allocatable, intent(inout) :: key(:)
+    class(*), intent(in)                :: value(:)
+    key = transfer( value, key )
+  end subroutine
+
+  subroutine set_first_key_int   ( key, value )
+    integer, intent(inout) :: key
+    class(*), intent(in)   :: value(:)
+    key = transfer( value(1), key )
+  end subroutine
+end module
+
+program p
+  use stdlib_hashmap_wrappers
+  implicit none
+  integer, allocatable :: a(:), b(:)
+  complex, allocatable :: c(:), d(:)
+  class(*),allocatable :: z(:)
+  integer :: m
+  a = [1, 2, 3, 4, 5]
+  c = cmplx (a, -a)
+  call set_rank_one_key_int (b, a)
+  call set_rank_one_key_cx  (d, c)
+  call set_first_key_int    (m, a)
+! print *, b
+! print *, d
+  if (size (a) /= size (b)) stop 1
+  if (any  (a  /=       b)) stop 2
+  if (size (c) /= size (d)) stop 3
+  if (any  (c  /=       d)) stop 4
+  if (m /= 1) stop 5
+  deallocate (d)
+  z = c
+  d = transfer (z, d)
+  if (size (c) /= size (d)) stop 6
+  if (any  (c  /=       d)) stop 7
+  deallocate (a, b, c, d, z)
+end program p