blob: 2f28d748504f8459ff888748a716e668e9ef80d5 [file] [log] [blame]
! { dg-do run }
!
! PR fortran/63205
!
! Check that passing a CLASS function result to a derived TYPE works
!
! Reported by Tobias Burnus <burnus@gcc.gnu.org>
!
program test
implicit none
type t
integer :: ii
end type t
type, extends(t) :: u
real :: rr
end type u
type, extends(t) :: v
real, allocatable :: rr(:)
end type v
type, extends(v) :: w
real, allocatable :: rrr(:)
end type w
type(t) :: x, y(3)
type(v) :: a, b(3)
x = func1() ! scalar to scalar - no alloc comps
if (x%ii .ne. 77) STOP 1
y = func2() ! array to array - no alloc comps
if (any (y%ii .ne. [1,2,3])) STOP 2
y = func1() ! scalar to array - no alloc comps
if (any (y%ii .ne. 77)) STOP 3
x = func3() ! scalar daughter type to scalar - no alloc comps
if (x%ii .ne. 99) STOP 4
y = func4() ! array daughter type to array - no alloc comps
if (any (y%ii .ne. [3,4,5])) STOP 5
y = func3() ! scalar daughter type to array - no alloc comps
if (any (y%ii .ne. [99,99,99])) STOP 6
a = func5() ! scalar to scalar - alloc comps in parent type
if (any (a%rr .ne. [10.0,20.0])) STOP 7
b = func6() ! array to array - alloc comps in parent type
if (any (b(3)%rr .ne. [3.0,4.0])) STOP 8
a = func7() ! scalar daughter type to scalar - alloc comps in parent type
if (any (a%rr .ne. [10.0,20.0])) STOP 9
b = func8() ! array daughter type to array - alloc comps in parent type
if (any (b(3)%rr .ne. [3.0,4.0])) STOP 10
b = func7() ! scalar daughter type to array - alloc comps in parent type
if (any (b(2)%rr .ne. [10.0,20.0])) STOP 11
! This is an extension of class_to_type_2.f90's test using a daughter type
! instead of the declared type.
if (subpr2_array (g ()) .ne. 99 ) STOP 12
contains
function func1() result(res)
class(t), allocatable :: res
allocate (res, source = t(77))
end function func1
function func2() result(res)
class(t), allocatable :: res(:)
allocate (res(3), source = [u(1,1.0),u(2,2.0),u(3,3.0)])
end function func2
function func3() result(res)
class(t), allocatable :: res
allocate (res, source = v(99,[99.0,99.0,99.0]))
end function func3
function func4() result(res)
class(t), allocatable :: res(:)
allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])])
end function func4
function func5() result(res)
class(v), allocatable :: res
allocate (res, source = v(3,[10.0,20.0]))
end function func5
function func6() result(res)
class(v), allocatable :: res(:)
allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])])
end function func6
function func7() result(res)
class(v), allocatable :: res
allocate (res, source = w(3,[10.0,20.0],[100,200]))
end function func7
function func8() result(res)
class(v), allocatable :: res(:)
allocate (res(3), source = [w(3,[1.0,2.0],[0.0]),w(4,[2.0,3.0],[0.0]),w(5,[3.0,4.0],[0.0])])
end function func8
integer function subpr2_array (x)
type(t) :: x(:)
if (any(x(:)%ii /= 55)) STOP 13
subpr2_array = 99
end function
function g () result(res)
integer i
class(t), allocatable :: res(:)
allocate (res(3), source = [(v (1, [1.0,2.0]), i = 1, 3)])
res(:)%ii = 55
end function g
end program test