gcc/testsuite/gfortran.dg/class_to_type_1.f03

   1 ! { dg-do run }
   2 !
   3 ! Passing CLASS to TYPE
   4 !
   5 implicit none
   6 type t
   7   integer :: A
   8   real, allocatable :: B(:)
   9 end type t
  10
  11 type, extends(t) ::  t2
  12   complex :: z = cmplx(3.3, 4.4)
  13 end type t2
  14 integer :: i
  15 class(t), allocatable :: x(:)
  16
  17 allocate(t2 :: x(10))
  18 select type(x)
  19  type is(t2)
  20   if (size (x) /= 10) STOP 1
  21   x = [(t2(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
  22   do i = 1, 10
  23     if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
  24         .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
  25         STOP 2
  26     end if
  27     if (x(i)%z /= cmplx(3.3, 4.4)) STOP 3
  28   end do
  29   class default
  30     STOP 4
  31 end select
  32
  33 call base(x)
  34 call baseExplicit(x, size(x))
  35 call class(x)
  36 call classExplicit(x, size(x))
  37 contains
  38   subroutine base(y)
  39     type(t) :: y(:)
  40     if (size (y) /= 10) STOP 5
  41     do i = 1, 10
  42       if (y(i)%a /= -i .or. size (y(i)%b) /= 4 &
  43           .or. any (y(i)%b /= [1*i,2*i,3*i,4*i])) then
  44         STOP 6
  45       end if
  46     end do
  47   end subroutine base
  48   subroutine baseExplicit(v, n)
  49     integer, intent(in) :: n
  50     type(t) :: v(n)
  51     if (size (v) /= 10) STOP 7
  52     do i = 1, 10
  53       if (v(i)%a /= -i .or. size (v(i)%b) /= 4 &
  54           .or. any (v(i)%b /= [1*i,2*i,3*i,4*i])) then
  55         STOP 8
  56       end if
  57     end do
  58   end subroutine baseExplicit
  59   subroutine class(z)
  60     class(t), intent(in) :: z(:)
  61     select type(z)
  62      type is(t2)
  63       if (size (z) /= 10) STOP 9
  64       do i = 1, 10
  65         if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
  66             .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
  67             STOP 10
  68         end if
  69         if (z(i)%z /= cmplx(3.3, 4.4)) STOP 11
  70       end do
  71       class default
  72         STOP 12
  73     end select
  74     call base(z)
  75     call baseExplicit(z, size(z))
  76   end subroutine class
  77   subroutine classExplicit(u, n)
  78     integer, intent(in) :: n
  79     class(t), intent(in) :: u(n)
  80     select type(u)
  81      type is(t2)
  82       if (size (u) /= 10) STOP 13
  83       do i = 1, 10
  84         if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
  85             .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
  86             STOP 14
  87         end if
  88         if (u(i)%z /= cmplx(3.3, 4.4)) STOP 15
  89       end do
  90       class default
  91         STOP 16
  92     end select
  93     call base(u)
  94     call baseExplicit(u, n)
  95   end subroutine classExplicit
  96 end
  97