[gcc r16-3551] Fortran: fix TRANSFER with rank 1 unlimited polymorphic SOURCE [PR121263]

[Harald Anlauf]

https://gcc.gnu.org/g:692281a38773a70ae795b3b594f0c0f8fd83e5ef

commit r16-3551-g692281a38773a70ae795b3b594f0c0f8fd83e5ef
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Wed Sep 3 20:41:20 2025 +0200

    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.

Diff:
---
 gcc/fortran/trans-intrinsic.cc                 |  7 +++-
 gcc/testsuite/gfortran.dg/transfer_class_5.f90 | 53 ++++++++++++++++++++++++++
 2 files changed, 59 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 71556b1c4ef3..e720b42355f4 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8651,7 +8651,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
index 000000000000..4ce5eb9f31ef
--- /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