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) call abort ()
  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         call abort()
  26     end if
  27     if (x(i)%z /= cmplx(3.3, 4.4)) call abort()
  28   end do
  29   class default
  30     call abort()
  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) call abort ()
  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         call abort()
  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) call abort ()
  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         call abort()
  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) call abort ()
  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             call abort()
  68         end if
  69         if (z(i)%z /= cmplx(3.3, 4.4)) call abort()
  70       end do
  71       class default
  72         call abort()
  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) call abort ()
  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             call abort()
  87         end if
  88         if (u(i)%z /= cmplx(3.3, 4.4)) call abort()
  89       end do
  90       class default
  91         call abort()
  92     end select
  93     call base(u)
  94     call baseExplicit(u, n)
  95   end subroutine classExplicit
  96 end
  97