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