gcc/testsuite/gfortran.dg/class_to_type_4.f90

   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
  10 program 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) STOP 1
  30
  31   y = func2() ! array to array - no alloc comps
  32   if (any (y%ii .ne. [1,2,3])) STOP 2
  33
  34   y = func1() ! scalar to array - no alloc comps
  35   if (any (y%ii .ne. 77)) STOP 3
  36
  37   x = func3() ! scalar daughter type to scalar - no alloc comps
  38   if (x%ii .ne. 99) STOP 4
  39
  40   y = func4() ! array daughter type to array - no alloc comps
  41   if (any (y%ii .ne. [3,4,5])) STOP 5
  42
  43   y = func3() ! scalar daughter type to array - no alloc comps
  44   if (any (y%ii .ne. [99,99,99])) STOP 6
  45
  46   a = func5() ! scalar to scalar - alloc comps in parent type
  47   if (any (a%rr .ne. [10.0,20.0])) STOP 7
  48
  49   b = func6() ! array to array - alloc comps in parent type
  50   if (any (b(3)%rr .ne. [3.0,4.0])) STOP 8
  51
  52   a = func7() ! scalar daughter type to scalar - alloc comps in parent type
  53   if (any (a%rr .ne. [10.0,20.0])) STOP 9
  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])) STOP 10
  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])) STOP 11
  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 ) STOP 12
  64 contains
  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)) STOP 13
 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
 119 end program test