https://gcc.gnu.org/bugzilla/show_bug.cgi?id=51284
--- Comment #8 from Mikael Morin <mikael at gcc dot gnu.org> ---
Here is another testcase, with a scalar passed to an assumed rank dummy:
program prog
implicit none
type :: t1
integer :: c1, c2
end type
type, extends(t1) :: t2
integer :: c3
end type
type(t2) :: x(5)
class(t1), allocatable :: y(:)
integer :: i
x = [ (t2(i*i*i, i*i, i), i=1,5) ]
y = x
call s(x(3), 1)
if (x(3)%c1 /= 27) error stop 141
if (x(3)%c2 /= 9) error stop 142
if (x(3)%c3 /= 3) error stop 143
call s(y(3), 2)
if (y(3)%c1 /= 27) error stop 241
if (y(3)%c2 /= 9) error stop 242
select type(y)
type is (t2)
if (y(3)%c3 /= 3) error stop 243
class default
error stop 249
end select
contains
subroutine s(a, e)
class(t1), value :: a
integer, intent(in) :: e
if (a%c1 /= 27) error stop e * 100 + 1
if (a%c2 /= 9) error stop e * 100 + 2
select type (a)
type is (t2)
if (a%c3 /= 3) error stop e * 100 + 3
class default
error stop 9
end select
call ar(a, e)
if (a%c1 /= 12) error stop e * 100 + 11
if (a%c2 /= 8) error stop e * 100 + 12
select type (a)
type is (t2)
if (a%c3 /= 4) error stop e * 100 + 13
class default
error stop e * 100 + 19
end select
end subroutine
subroutine ar(a, e)
class(t1) :: a(..)
integer, intent(in) :: e
select rank (a)
rank(0)
call check(a, e)
rank default
error stop e * 100 + 21
end select
end subroutine
subroutine check(a, e)
class(t1) :: a
integer, intent(in) :: e
if (a%c1 /= 27) error stop e * 100 + 31
a%c1 = 12
if (a%c2 /= 9) error stop e * 100 + 32
a%c2 = 8
select type (a)
type is (t2)
if (a%c3 /= 3) error stop e * 100 + 33
a%c3 = 4
class default
error stop e * 100 + 39
end select
end subroutine
end program
The dump has:
void s (struct __class_prog_T1_t a, integer(kind=4) & restrict e)
{
...
}
void prog ()
{
...
{
struct __class_prog_T1_t class.13;
...
s (&class.13, &C.4931);
}
...
}
so a pointer to the class descriptor is passed to the function, which expects
the descriptor itself directly. Ooops.
