https://gcc.gnu.org/g:8e0229b719cf68d190e5f4adecb54878b235039d
commit 8e0229b719cf68d190e5f4adecb54878b235039d Author: Mikael Morin <[email protected]> Date: Mon Nov 2 12:24:38 2026 +0100 fortran: Use polymorphic assignment to copy a class value to a temporary [PR128349] Propagate class information from the original variable when copying to a temporary, so that the copy assignment doesn't fall back to non-polymorphic assignment. In the example added to the testsuite here, the class container doesn't appear as prefix of the array reference, because of a temporary variable. As a result, in trans_scalar_class_assign, the call to gfc_get_class_from_expr is unable to guess any reference to the class container, and we fall back to non-polymorphic assignment. This change uses the class container reference that is already saved by the scalarizer, and copies it to the expression metadata. And in trans_scalar_class_assign, usage of that class container metadata is tried first if it is present, before falling back to the existing handling. PR fortran/128349 gcc/fortran/ChangeLog: * trans-expr.cc (gfc_conv_variable): Set class container expression from the one saved by the scalarizer. (trans_scalar_class_assign): Use previously set class container expression if it's available. gcc/testsuite/ChangeLog: * gfortran.dg/unlimited_polymorphic_34.f90: New test. Diff: --- gcc/fortran/trans-expr.cc | 6 +++- .../gfortran.dg/unlimited_polymorphic_34.f90 | 41 ++++++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index c81051f71623..558de49cbedb 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1966,7 +1966,10 @@ trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse) if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) || not_call_expr) { - tmp = gfc_get_class_from_expr (rse->expr); + if (rse->class_container != NULL_TREE) + tmp = rse->class_container; + else + tmp = gfc_get_class_from_expr (rse->expr); if (tmp == NULL_TREE) return false; rse_expr = gfc_evaluate_now (tmp, block); @@ -3187,6 +3190,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && ref->u.ar.type != AR_ELEMENT); else gfc_conv_tmp_array_ref (se); + se->class_container = ss_info->class_container; } else { diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_34.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_34.f90 new file mode 100644 index 000000000000..748d453794dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_34.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/PR128349 +! Check that to evaluate the TRANSFER intrinsic call, the copy to a temporary +! array is done using the polymorphic copy function instead of a regular +! assignment of void pointer values. + +program prog + implicit none + integer, parameter :: n = 5 + type :: t1 + integer :: c1, c2, c3 + end type + type :: t2 + integer :: c1, c2, c3 + end type + type(t1) :: a(n) + integer :: i + a = [ (t1(2*i+1, 3*i*i+2, 5*i*i+3), i=1, n) ] + call sub(a) +contains + subroutine sub(x) + class(*), intent(in) :: x(:) + type(t2) :: y(n) + call check_t2(transfer(x, y)) + end subroutine + subroutine check_t2(x) + type(t2), target, intent(in) :: x(:) + call check(x%c1, [3, 5, 7, 9, 11], 1) + call check(x%c2, [5, 14, 29, 50, 77], 2) + call check(x%c3, [8, 23, 48, 83, 128], 3) + end subroutine + subroutine check(x, y, e) + integer, intent(in) :: x(:), y(:), e + if (size(x) /= size(y)) error stop e*10+8 + !do i=1,size(x) + ! print *, e*10+i, (x(i) == y(i) ? "PASS" : "FAIL"), x(i), y(i) + !end do + if (any(x /= y)) error stop e*10+9 + end subroutine +end program
