1! { dg-do run }
2!
3! PR fortran/51972
4! Also tests fixes for PR52102
5!
6! Check whether DT assignment with polymorphic components works.
7!
8
9subroutine test1 ()
10  type t
11    integer :: x
12  end type t
13
14  type t2
15    class(t), allocatable :: a
16  end type t2
17
18  type(t2) :: one, two
19
20  one = two
21  if (allocated (one%a)) call abort ()
22
23  allocate (two%a)
24  two%a%x = 7890
25  one = two
26  if (one%a%x /= 7890) call abort ()
27
28  deallocate (two%a)
29  one = two
30  if (allocated (one%a)) call abort ()
31end subroutine test1
32
33subroutine test2 ()
34  type t
35    integer, allocatable :: x(:)
36  end type t
37
38  type t2
39    class(t), allocatable :: a
40  end type t2
41
42  type(t2) :: one, two
43
44  one = two
45  if (allocated (one%a)) call abort ()
46
47  allocate (two%a)
48  one = two
49  if (.not.allocated (one%a)) call abort ()
50  if (allocated (one%a%x)) call abort ()
51
52  allocate (two%a%x(2))
53  two%a%x(:) = 7890
54  one = two
55  if (any (one%a%x /= 7890)) call abort ()
56
57  deallocate (two%a)
58  one = two
59  if (allocated (one%a)) call abort ()
60end subroutine test2
61
62
63subroutine test3 ()
64  type t
65    integer :: x
66  end type t
67
68  type t2
69    class(t), allocatable :: a(:)
70  end type t2
71
72  type(t2) :: one, two
73
74! Test allocate with array source - PR52102
75  allocate (two%a(2), source = [t(4), t(6)])
76
77  if (allocated (one%a)) call abort ()
78
79  one = two
80  if (.not.allocated (one%a)) call abort ()
81
82  if ((one%a(1)%x /= 4)) call abort ()
83  if ((one%a(2)%x /= 6)) call abort ()
84
85  deallocate (two%a)
86  one = two
87
88  if (allocated (one%a)) call abort ()
89
90! Test allocate with no source followed by assignments.
91  allocate (two%a(2))
92  two%a(1)%x = 5
93  two%a(2)%x = 7
94
95  if (allocated (one%a)) call abort ()
96
97  one = two
98  if (.not.allocated (one%a)) call abort ()
99
100  if ((one%a(1)%x /= 5)) call abort ()
101  if ((one%a(2)%x /= 7)) call abort ()
102
103  deallocate (two%a)
104  one = two
105  if (allocated (one%a)) call abort ()
106end subroutine test3
107
108subroutine test4 ()
109  type t
110    integer, allocatable :: x(:)
111  end type t
112
113  type t2
114    class(t), allocatable :: a(:)
115  end type t2
116
117  type(t2) :: one, two
118
119  if (allocated (one%a)) call abort ()
120  if (allocated (two%a)) call abort ()
121
122  allocate (two%a(2))
123
124  if (allocated (two%a(1)%x)) call abort ()
125  if (allocated (two%a(2)%x)) call abort ()
126  allocate (two%a(1)%x(3), source=[1,2,3])
127  allocate (two%a(2)%x(5), source=[5,6,7,8,9])
128  one = two
129  if (.not. allocated (one%a)) call abort ()
130  if (.not. allocated (one%a(1)%x)) call abort ()
131  if (.not. allocated (one%a(2)%x)) call abort ()
132
133  if (size(one%a) /= 2) call abort()
134  if (size(one%a(1)%x) /= 3) call abort()
135  if (size(one%a(2)%x) /= 5) call abort()
136  if (any (one%a(1)%x /= [1,2,3])) call abort ()
137  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
138
139  deallocate (two%a(1)%x)
140  one = two
141  if (.not. allocated (one%a)) call abort ()
142  if (allocated (one%a(1)%x)) call abort ()
143  if (.not. allocated (one%a(2)%x)) call abort ()
144
145  if (size(one%a) /= 2) call abort()
146  if (size(one%a(2)%x) /= 5) call abort()
147  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
148
149  deallocate (two%a)
150  one = two
151  if (allocated (one%a)) call abort ()
152  if (allocated (two%a)) call abort ()
153end subroutine test4
154
155
156call test1 ()
157call test2 ()
158call test3 ()
159call test4 ()
160end
161
162