From: Mikael Morin <[email protected]>
Fortran-tested on aarch64-unknown-linux-gnu and powerpc64-unknown-linux-gnu
without regression, and it fixes the transfer_class_5.f90 regression
with -m32 on powerpc.
I plan to push to trunk in two days if I don't get any comment about it.
-- >8 --
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 if not.
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.
---
gcc/fortran/trans-expr.cc | 6 ++-
.../gfortran.dg/unlimited_polymorphic_34.f90 | 41 +++++++++++++++++++
2 files changed, 46 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_34.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c81051f7162..558de49cbed 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 00000000000..748d453794d
--- /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
--
2.53.0
