https://gcc.gnu.org/bugzilla/show_bug.cgi?id=127827
Bug ID: 127827
Summary: Array span incorrectly set when passing a polymorphic
dummy to a target assumed-shape dummy
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
end type
type, extends(t1) :: t2
integer :: c3
end type
type(t2), target :: a(n)
integer :: i
a = [ (t2(3*i*i+2, i*i+1, 5*i+3), i=1,size(a)) ]
call check_all(a%t1, 1)
call type_wrapper(a%t1, 2, 3)
call class_wrapper(a%t1, 4)
contains
subroutine type_wrapper(x, e1, e2)
type(t1), target, intent(in) :: x(:)
integer, intent(in) :: e1, e2
call check_all(x, e1)
call class_wrapper(x, e2)
end subroutine
subroutine class_wrapper(x, e)
class(t1), target, intent(in) :: x(:)
integer, intent(in) :: e
call check_all(x, e)
end subroutine
subroutine check_all(x, e)
type(t1), target, intent(in) :: x(:)
integer, intent(in) :: e
call check(x%c1, [ 5, 14, 29, 50, 77 ], e*10+1)
call check(x%c2, [ 2, 5, 10, 17, 26 ], e*10+2)
end subroutine
subroutine check(a, v, e)
integer, intent(in), dimension(:) :: a, v
integer, intent(in) :: e
integer :: i
if (size(a) /= size(v)) error stop e*10
do i = 1, size(a)
print *, e*10+i, (a(i) == v(i) ? "PASS" : "FAIL"), a(i), v(i)
end do
! if (any(a /= v)) error stop e*10+9
end subroutine
end program
When run, it shows as output:
111 PASS 5 5
112 PASS 14 14
113 PASS 29 29
114 PASS 50 50
115 PASS 77 77
121 PASS 2 2
122 PASS 5 5
123 PASS 10 10
124 PASS 17 17
125 PASS 26 26
211 PASS 5 5
212 PASS 14 14
213 PASS 29 29
214 PASS 50 50
215 PASS 77 77
221 PASS 2 2
222 PASS 5 5
223 PASS 10 10
224 PASS 17 17
225 PASS 26 26
311 PASS 5 5
312 FAIL 8 14
313 FAIL 5 29
314 FAIL 29 50
315 FAIL 18 77
321 PASS 2 2
322 FAIL 14 5
323 FAIL 13 10
324 FAIL 10 17
325 FAIL 50 26
411 PASS 5 5
412 FAIL 8 14
413 FAIL 5 29
414 FAIL 29 50
415 FAIL 18 77
421 PASS 2 2
422 FAIL 14 5
423 FAIL 13 10
424 FAIL 10 17
425 FAIL 50 26
The expected output would have PASS in all lines and the same values in the two
last columns.
So any case where the class_wrapper subroutine is involved has wrong result.
The dump shows:
> void class_wrapper (struct __class_prog_T1_1_0t & x, integer(kind=4) &
> restrict e)
> {
> (...)
> struct t1[0:D.5012] * x.0;
> integer(kind=8) D.5012;
> (...)
> x.0 = (struct t1[0:D.5012] *) x->_data.data;
> ubound.27 = (x->_data.dim[0].ubound - x->_data.dim[0].lbound) + 1;
> size.30 = stride.28 * NON_LVALUE_EXPR <ubound.27>;
> (...)
> D.5012 = size.30 + -1;
> (...)
> parm.31.span = x->_vptr->_size;
> (...)
> parm.31.data = (void *) &(*x.0)[0];
> (...)
> check_all (&parm.31, (integer(kind=4) *) e);
> }
> }
which sets the span from the virtual table instead of from x's array
descriptor.
In gfc_conv_expr_descriptor, the span is set via:
8284 /* ....and set the span field. */
8285 if (ss_info->expr->ts.type == BT_CHARACTER)
8286 tmp = gfc_conv_descriptor_span_get (desc);
8287 else
8288 tmp = gfc_get_array_span (desc, expr);
8289 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
with `desc' holding the *x.0 expression.
gfc_get_array_span starts with the following which is supposed to handle
span-addressed dummies.
680 if (tree span = GFC_DECL_GET_SPAN (desc))
681 /* A span addressed dummy loaded its span on entry. */
682 tmp = span;
683 else if (is_span_addressed_array (desc)
684 || (get_CFI_desc (NULL, expr, &desc, NULL)
685 && (POINTER_TYPE_P (TREE_TYPE (desc))
686 ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE
(desc)))
687 : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
688 /* This will have the span field set. */
689 tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor
(desc));
The first condition isn't met because desc isn't a decl, but even if we unwrap
the dereference, x.0 doesn't have any GFC_DECL_SPAN, and its saved descriptor x
doesn't either.
In the second condition is_span_addressed_array returns false, and even if it
did return true, gfc_get_span_descriptor would return a non-descriptor because
desc isn't a decl.
