gcc/testsuite/gfortran.dg/pointer_array_8.f90

   1 ! { dg-do run }
   2 !
   3 ! Make sure that the fix for pr34640 works with class pointers.
   4 !
   5   type :: mytype
   6     real :: r
   7     integer :: i
   8   end type
   9
  10   type :: thytype
  11     real :: r
  12     integer :: i
  13     type(mytype) :: der
  14   end type
  15
  16   type(thytype), dimension(0:2), target :: tgt
  17   class(*), dimension(:), pointer :: cptr
  18   class(mytype), dimension(:), pointer :: cptr1
  19   integer :: i
  20   integer(8) :: s1, s2
  21
  22   tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)]
  23
  24   cptr => tgt%i
  25   if (lbound (cptr, 1) .ne. 1)  STOP 1! Not a whole array target!
  26
  27   s1 = loc(cptr)
  28   call foo (cptr, s2)                          ! Check bounds not changed...
  29   if (s1 .ne. s2) STOP 2! ...and that the descriptor is passed.
  30
  31   select type (cptr)
  32     type is (integer)
  33       if (any (cptr .ne. [1,2,3])) STOP 3! Check the the scalarizer works.
  34       if (cptr(2) .ne. 2) STOP 4! Check ordinary array indexing.
  35   end select
  36
  37   cptr(1:3) => tgt%der%r                       ! Something a tad more complicated!
  38
  39   select type (cptr)
  40     type is (real)
  41       if (any (int(cptr) .ne. [2,4,6])) STOP 5
  42       if (any (int(cptr([2,3,1])) .ne. [4,6,2])) STOP 6
  43       if (int(cptr(3)) .ne. 6) STOP 7
  44   end select
  45
  46   cptr1(1:3) => tgt%der
  47
  48   s1 = loc(cptr1)
  49   call bar(cptr1, s2)
  50   if (s1 .ne. s2) STOP 8! Check that the descriptor is passed.
  51
  52   select type (cptr1)
  53     type is (mytype)
  54       if (any (cptr1%i .ne. [2,4,6])) STOP 9
  55       if (cptr1(2)%i .ne. 4) STOP 10
  56   end select
  57
  58 contains
  59
  60   subroutine foo (arg, addr)
  61     class(*), dimension(:), pointer :: arg
  62     integer(8) :: addr
  63     addr = loc(arg)
  64     select type (arg)
  65       type is (integer)
  66         if (any (arg .ne. [1,2,3])) STOP 11! Check the the scalarizer works.
  67         if (arg(2) .ne. 2) STOP 12! Check ordinary array indexing.
  68     end select
  69   end subroutine
  70
  71   subroutine bar (arg, addr)
  72     class(mytype), dimension(:), pointer :: arg
  73     integer(8) :: addr
  74     addr = loc(arg)
  75     select type (arg)
  76       type is (mytype)
  77         if (any (arg%i .ne. [2,4,6])) STOP 13
  78         if (arg(2)%i .ne. 4) STOP 14
  79     end select
  80   end subroutine
  81 end