git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Harald Anlauf 2025-09-03 20:41:20 +02:00
parent 589f3cd183
commit 692281a387
2 changed files with 59 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/trans-intrinsic.cc
View File

@ -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);

53
gcc/testsuite/gfortran.dg/transfer_class_5.f90 Normal file
View File

@ -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