https://gcc.gnu.org/bugzilla/show_bug.cgi?id=128349
Bug ID: 128349
Summary: Copy to temporary doesn't use polymorphic assignment
Product: gcc
Version: 17.0
Status: UNCONFIRMED
Keywords: wrong-code
Severity: normal
Priority: P3
Component: fortran
Assignee: unassigned at gcc dot gnu.org
Reporter: mikael at gcc dot gnu.org
Target Milestone: ---
Testcase:
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
It has been created using the analysis at:
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=128345#c2
It produces failures on a broader set of platforms than the testsuite's
transfer_class_5.f90 of PR128345.
When executed, it produces as output:
11 PASS 3 3
12 PASS 5 5
13 PASS 7 7
14 PASS 9 9
15 PASS 11 11
21 PASS 5 5
22 PASS 14 14
23 PASS 29 29
24 PASS 50 50
25 PASS 77 77
31 FAIL 0 8
32 FAIL 0 23
33 FAIL 0 48
34 FAIL 0 83
35 FAIL 0 128
showing that only part of the value is copied and made available as input
argument to check_t2.
The problem is triggered by the TRANSFER intrinsic, but that is only useful to
force the creation of a temporary:
8851 bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8852 false, true);
8853 argse.want_pointer = 0;
8854 /* A non-contiguous SOURCE needs packing. */
8855 if (!simply_contiguous)
8856 argse.force_tmp = 1;
8857 gfc_conv_expr_descriptor (&argse, arg->expr);
The problem is an assignment to a temporary that is not done using the
polymorphic copy function, and falls back to normal assignment of void pointer
values, which only copies the size of a pointer:
> D.5053 = ctmp.37._data.dim[0].stride;
> D.5054 = stride.33;
> S.38 = 0;
> while (1)
> {
> if (S.38 > D.5039) goto L.10;
> {
> (...)
> D.5059 = x->_vptr;
> D.5060 = x->_vptr->_size;
> D.5061 = x->_len;
> D.5062 = D.5061 > 0 ? D.5060 * D.5061 : D.5060;
> D.5055 = ctmp.37._vptr;
> D.5056 = ctmp.37._vptr->_size;
> D.5057 = ctmp.37._len;
> D.5058 = D.5057 > 0 ? D.5056 * D.5057 : D.5056;
> *(void * *) (ctmp.37._data.data + (sizetype) ((S.38 * D.5053) *
> D.5058)) = *((void * *) D.5032 + (sizetype) (((S.38 + 1) * D.5054 + D.5033) *
> D.5062));
> }
> S.38 = S.38 + 1;
> }
> L.10:;
In trans_scalar_class_assign:
1965 /* Fix the class expression and the class data of the rhs. */
1966 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1967 || not_call_expr)
1968 {
1969 tmp = gfc_get_class_from_expr (rse->expr);
1970 if (tmp == NULL_TREE)
1971 return false;
1972 rse_expr = gfc_evaluate_now (tmp, block);
1973 }
1974 else
1975 rse_expr = gfc_evaluate_now (rse->expr, block);
as gfc_get_class_from_expr is unable to find the reference to the class
container from the rhs expression, false is returned and the non-polymorphic
fall back assignment is used.
