gcc/testsuite/gfortran.dg/class_to_type_2.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/51514
   4 !
   5 ! Check that passing a CLASS to a TYPE works
   6 !
   7 ! Based on a test case of Reinhold Bader.
   8 !
   9
  10 module mod_subpr
  11   implicit none
  12
  13   type :: foo
  14     integer :: i = 2
  15   end type
  16
  17   type, extends(foo) :: foo_1
  18     real :: r(2)
  19   end type
  20
  21 contains
  22
  23   subroutine subpr (x)
  24     type(foo) :: x
  25     x%i = 3
  26   end subroutine
  27
  28   elemental subroutine subpr_elem (x)
  29     type(foo), intent(inout):: x
  30     x%i = 3
  31   end subroutine
  32
  33   subroutine subpr_array (x)
  34     type(foo), intent(inout):: x(:)
  35     x(:)%i = 3
  36   end subroutine
  37
  38   subroutine subpr2 (x)
  39     type(foo) :: x
  40     if (x%i /= 55) call abort ()
  41   end subroutine
  42
  43   subroutine subpr2_array (x)
  44     type(foo) :: x(:)
  45     if (any(x(:)%i /= 55)) call abort ()
  46   end subroutine
  47
  48   function f ()
  49     class(foo), allocatable :: f
  50     allocate (f)
  51     f%i = 55
  52   end function f
  53
  54   function g () result(res)
  55     class(foo), allocatable :: res(:)
  56     allocate (res(3))
  57     res(:)%i = 55
  58   end function g
  59 end module
  60
  61 program prog
  62   use mod_subpr
  63   implicit none
  64   class(foo), allocatable :: xx, yy(:)
  65
  66   allocate (foo_1 :: xx)
  67   xx%i = 33
  68   call subpr (xx)
  69   if (xx%i /= 3) call abort ()
  70
  71   xx%i = 33
  72   call subpr_elem (xx)
  73   if (xx%i /= 3) call abort ()
  74
  75   call subpr (f ())
  76
  77   allocate (foo_1 :: yy(2))
  78   yy(:)%i = 33
  79   call subpr_elem (yy)
  80   if (any (yy%i /= 3)) call abort ()
  81
  82   yy(:)%i = 33
  83   call subpr_elem (yy(1))
  84   if (yy(1)%i /= 3) call abort ()
  85
  86   yy(:)%i = 33
  87   call subpr_array (yy)
  88   if (any (yy%i /= 3)) call abort ()
  89
  90   yy(:)%i = 33
  91   call subpr_array (yy(1:2))
  92   if (any (yy(1:2)%i /= 3)) call abort ()
  93
  94  call subpr2_array (g ())
  95 end program