1! { dg-do run }
2! Tests the fix for PR59414, comment #3, in which the allocate
3! expressions were not correctly being stripped to provide the
4! vpointer as an lhs to the pointer assignment of the vptr from
5! the SOURCE expression.
6!
7! Contributed by Antony Lewis  <antony@cosmologist.info>
8!
9module ObjectLists
10  implicit none
11
12  type :: t
13    integer :: i
14  end type
15
16  type Object_array_pointer
17    class(t), pointer :: p(:)
18  end type
19
20contains
21
22  subroutine AddArray1 (P, Pt)
23    class(t) :: P(:)
24    class(Object_array_pointer) :: Pt
25
26    select type (Pt)
27    class is (Object_array_pointer)
28      if (associated (Pt%P)) deallocate (Pt%P)
29      allocate(Pt%P(1:SIZE(P)), source=P)
30    end select
31  end subroutine
32
33  subroutine AddArray2 (P, Pt)
34    class(t) :: P(:)
35    class(Object_array_pointer) :: Pt
36
37    select type (Pt)
38    type is (Object_array_pointer)
39      if (associated (Pt%P)) deallocate (Pt%P)
40      allocate(Pt%P(1:SIZE(P)), source=P)
41    end select
42  end subroutine
43
44  subroutine AddArray3 (P, Pt)
45    class(t) :: P
46    class(Object_array_pointer) :: Pt
47
48    select type (Pt)
49    class is (Object_array_pointer)
50      if (associated (Pt%P)) deallocate (Pt%P)
51      allocate(Pt%P(1:4), source=P)
52    end select
53  end subroutine
54
55  subroutine AddArray4 (P, Pt)
56    type(t) :: P(:)
57    class(Object_array_pointer) :: Pt
58
59    select type (Pt)
60    class is (Object_array_pointer)
61      if (associated (Pt%P)) deallocate (Pt%P)
62      allocate(Pt%P(1:SIZE(P)), source=P)
63    end select
64  end subroutine
65end module
66
67  use ObjectLists
68  type(Object_array_pointer), pointer :: Pt
69  class(t), pointer :: P(:)
70
71  allocate (P(2), source = [t(1),t(2)])
72  allocate (Pt, source = Object_array_pointer(NULL()))
73  call AddArray1 (P, Pt)
74  select type (x => Pt%p)
75    type is (t)
76      if (any (x%i .ne. [1,2])) call abort
77  end select
78  deallocate (P)
79  deallocate (pt)
80
81  allocate (P(3), source = [t(3),t(4),t(5)])
82  allocate (Pt, source = Object_array_pointer(NULL()))
83  call AddArray2 (P, Pt)
84  select type (x => Pt%p)
85    type is (t)
86      if (any (x%i .ne. [3,4,5])) call abort
87  end select
88  deallocate (P)
89  deallocate (pt)
90
91  allocate (Pt, source = Object_array_pointer(NULL()))
92  call AddArray3 (t(6), Pt)
93  select type (x => Pt%p)
94    type is (t)
95      if (any (x%i .ne. [6,6,6,6])) call abort
96  end select
97  deallocate (pt)
98
99  allocate (Pt, source = Object_array_pointer(NULL()))
100  call AddArray4 ([t(7), t(8)], Pt)
101  select type (x => Pt%p)
102    type is (t)
103      if (any (x%i .ne. [7,8])) call abort
104  end select
105  deallocate (pt)
106 end
107
108