gcc/testsuite/gfortran.dg/type_to_class_1.f03

   1 ! { dg-do run }
   2 !
   3 ! Passing TYPE to CLASS
   4 !
   5 implicit none
   6 type t
   7   integer :: A
   8   real, allocatable :: B(:)
   9 end type t
  10
  11 type(t), allocatable :: x(:)
  12 type(t) :: y(10)
  13 integer :: i
  14
  15 allocate(x(10))
  16 if (size (x) /= 10) STOP 1
  17 x = [(t(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
  18 do i = 1, 10
  19   if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
  20       .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
  21       STOP 2
  22   end if
  23 end do
  24
  25 y = x ! TODO: Segfaults in runtime without 'y' being set
  26
  27 call class(x)
  28 call classExplicit(x, size(x))
  29 call class(y)
  30 call classExplicit(y, size(y))
  31
  32 contains
  33   subroutine class(z)
  34     class(t), intent(in) :: z(:)
  35     select type(z)
  36      type is(t)
  37       if (size (z) /= 10) STOP 3
  38       do i = 1, 10
  39         if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
  40             .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
  41             STOP 4
  42         end if
  43       end do
  44       class default
  45         STOP 5
  46     end select
  47   end subroutine class
  48   subroutine classExplicit(u, n)
  49     integer, intent(in) :: n
  50     class(t), intent(in) :: u(n)
  51     select type(u)
  52      type is(t)
  53       if (size (u) /= 10) STOP 6
  54       do i = 1, 10
  55         if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
  56             .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
  57             STOP 7
  58         end if
  59       end do
  60       class default
  61         STOP 8
  62     end select
  63   end subroutine classExplicit
  64 end
  65