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

[Harald Anlauf]

Dear all,

here's an attempt to fix a technical regression for TRANSFER with
an unlimited polymorphic SOURCE argument.  As this is something
where others are more familiar with (Paul?), I might have missed
something, so be extra careful when reviewing.

Otherwise regtests fine on x86_64-pc-linux-gnu.  OK for trunk/backports?

Thanks,
Harald


From a0f68c15e7def3228a4e27ac576b87517bad997a Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Tue, 2 Sep 2025 22:24:42 +0200
Subject: [PATCH] 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                |  7 ++-
 .../gfortran.dg/transfer_class_5.f90          | 47 +++++++++++++++++++
 2 files changed, 53 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/transfer_class_5.f90

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 71556b1c4ef..e720b42355f 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 00000000000..2429d5b097a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_5.f90
@@ -0,0 +1,47 @@
+! { 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(:)
+  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 (a, b, c, d)
+end program p
-- 
2.51.0