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