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)  Call abort     ! Not a whole array target!
  26
  27   s1 = loc(cptr)
  28   call foo (cptr, s2)                          ! Check bounds not changed...
  29   if (s1 .ne. s2) Call abort                   ! ...and that the descriptor is passed.
  30
  31   select type (cptr)
  32     type is (integer)
  33       if (any (cptr .ne. [1,2,3])) call abort  ! Check the the scalarizer works.
  34       if (cptr(2) .ne. 2) call abort           ! 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])) call abort
  42       if (any (int(cptr([2,3,1])) .ne. [4,6,2])) call abort
  43       if (int(cptr(3)) .ne. 6) call abort
  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) Call abort                   ! Check that the descriptor is passed.
  51
  52   select type (cptr1)
  53     type is (mytype)
  54       if (any (cptr1%i .ne. [2,4,6])) call abort
  55       if (cptr1(2)%i .ne. 4) call abort
  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])) call abort  ! Check the the scalarizer works.
  67         if (arg(2) .ne. 2) call abort           ! 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])) call abort
  78         if (arg(2)%i .ne. 4) call abort
  79     end select
  80   end subroutine
  81 end