https://gcc.gnu.org/g:692281a38773a70ae795b3b594f0c0f8fd83e5ef
commit r16-3551-g692281a38773a70ae795b3b594f0c0f8fd83e5ef
Author: Harald Anlauf <anl...@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
