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.

gcc/fortran/trans-intrinsic.cc

@@ -8651,6 +8651,11 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 				       argse.string_length);
       else if (arg->expr->ts.type == BT_CLASS)
 	{
+	  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))

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