gcc/testsuite/gfortran.dg/class_array_21.f03

   1 ! { dg-do run }
   2 !
   3 ! Contributed by Andre Vehreschild
   4 ! Check more elaborate class array addressing.
   5
   6 module m1
   7
   8   type InnerBaseT
   9     integer, allocatable :: a(:)
  10   end type InnerBaseT
  11
  12   type, extends(InnerBaseT) :: InnerT
  13     integer :: i
  14   end type InnerT
  15
  16   type BaseT
  17     class(InnerT), allocatable :: arr(:,:)
  18   contains
  19     procedure P
  20   end type BaseT
  21
  22 contains
  23
  24   subroutine indir(this, mat)
  25     class(BaseT) :: this
  26     class(InnerT), intent(inout) :: mat(:,:)
  27
  28     call this%P(mat)
  29   end subroutine indir
  30
  31   subroutine P(this, mat)
  32     class(BaseT) :: this
  33     class(InnerT), intent(inout) :: mat(:,:)
  34     integer :: i,j
  35
  36     mat%i = 42
  37     do i= 1, ubound(mat, 1)
  38       do j= 1, ubound(mat, 2)
  39         if (.not. allocated(mat(i,j)%a)) then
  40           allocate(mat(i,j)%a(10), source = 72)
  41         end if
  42       end do
  43     end do
  44     mat(1,1)%i = 9
  45     mat(1,1)%a(5) = 1
  46   end subroutine
  47
  48 end module m1
  49
  50 program test
  51   use m1
  52
  53   class(BaseT), allocatable, target :: o
  54   class(InnerT), pointer :: i_p(:,:)
  55   class(InnerBaseT), allocatable :: i_a(:,:)
  56   integer i,j,l
  57
  58   allocate(o)
  59   allocate(o%arr(2,2))
  60   allocate(InnerT::i_a(2,2))
  61   o%arr%i = 1
  62
  63   i_p => o%arr
  64   call o%P(i_p)
  65   if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort()
  66   do l= 1, 10
  67     do i= 1, 2
  68       do j= 1,2
  69         if ((i == 1 .and. j == 1 .and. l == 5 .and. &
  70              o%arr(i,j)%a(5) /= 1) &
  71             .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
  72               .and. o%arr(i,j)%a(l) /= 72)) call abort()
  73       end do
  74     end do
  75   end do
  76
  77   select type (i_a)
  78     type is (InnerT)
  79       call o%P(i_a)
  80       do l= 1, 10
  81         do i= 1, 2
  82           do j= 1,2
  83             if ((i == 1 .and. j == 1 .and. l == 5 .and. &
  84                  i_a(i,j)%a(5) /= 1) &
  85                 .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
  86                   .and. i_a(i,j)%a(l) /= 72)) call abort()
  87           end do
  88         end do
  89       end do
  90   end select
  91
  92   i_p%i = 4
  93   call indir(o, i_p)
  94   if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort()
  95 end program test
  96
  97 ! vim:ts=2:sts=2:cindent:sw=2:tw=80: