1! { dg-do run }
2!
3! PR fortran/63205
4!
5! Check that passing a CLASS function result to a derived TYPE works
6!
7! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
8!
9
10program test
11  implicit none
12  type t
13    integer :: ii
14  end type t
15  type, extends(t) :: u
16    real :: rr
17  end type u
18  type, extends(t) :: v
19    real, allocatable :: rr(:)
20  end type v
21  type, extends(v) :: w
22    real, allocatable :: rrr(:)
23  end type w
24
25  type(t) :: x, y(3)
26  type(v) :: a, b(3)
27
28  x = func1() ! scalar to scalar - no alloc comps
29  if (x%ii .ne. 77) call abort
30
31  y = func2() ! array to array - no alloc comps
32  if (any (y%ii .ne. [1,2,3])) call abort
33
34  y = func1() ! scalar to array - no alloc comps
35  if (any (y%ii .ne. 77)) call abort
36
37  x = func3() ! scalar daughter type to scalar - no alloc comps
38  if (x%ii .ne. 99) call abort
39
40  y = func4() ! array daughter type to array - no alloc comps
41  if (any (y%ii .ne. [3,4,5])) call abort
42
43  y = func3() ! scalar daughter type to array - no alloc comps
44  if (any (y%ii .ne. [99,99,99])) call abort
45
46  a = func5() ! scalar to scalar - alloc comps in parent type
47  if (any (a%rr .ne. [10.0,20.0])) call abort
48
49  b = func6() ! array to array - alloc comps in parent type
50  if (any (b(3)%rr .ne. [3.0,4.0])) call abort
51
52  a = func7() ! scalar daughter type to scalar - alloc comps in parent type
53  if (any (a%rr .ne. [10.0,20.0])) call abort
54
55  b = func8() ! array daughter type to array - alloc comps in parent type
56  if (any (b(3)%rr .ne. [3.0,4.0])) call abort
57
58  b = func7() ! scalar daughter type to array - alloc comps in parent type
59  if (any (b(2)%rr .ne. [10.0,20.0])) call abort
60
61! This is an extension of class_to_type_2.f90's test using a daughter type
62! instead of the declared type.
63  if (subpr2_array (g ()) .ne. 99 ) call abort
64contains
65
66  function func1() result(res)
67    class(t), allocatable :: res
68    allocate (res, source = t(77))
69  end function func1
70
71  function func2() result(res)
72    class(t), allocatable :: res(:)
73    allocate (res(3), source = [u(1,1.0),u(2,2.0),u(3,3.0)])
74  end function func2
75
76  function func3() result(res)
77    class(t), allocatable :: res
78    allocate (res, source = v(99,[99.0,99.0,99.0]))
79  end function func3
80
81  function func4() result(res)
82    class(t), allocatable :: res(:)
83    allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])])
84  end function func4
85
86  function func5() result(res)
87    class(v), allocatable :: res
88    allocate (res, source = v(3,[10.0,20.0]))
89  end function func5
90
91  function func6() result(res)
92    class(v), allocatable :: res(:)
93    allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])])
94  end function func6
95
96  function func7() result(res)
97    class(v), allocatable :: res
98    allocate (res, source = w(3,[10.0,20.0],[100,200]))
99  end function func7
100
101  function func8() result(res)
102    class(v), allocatable :: res(:)
103    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])])
104  end function func8
105
106
107  integer function subpr2_array (x)
108    type(t) :: x(:)
109    if (any(x(:)%ii /= 55)) call abort
110    subpr2_array = 99
111  end function
112
113  function g () result(res)
114    integer i
115    class(t), allocatable :: res(:)
116    allocate (res(3), source = [(v (1, [1.0,2.0]), i = 1, 3)])
117    res(:)%ii = 55
118  end function g
119end program test
120