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 58contains 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 81end 82