1! RUN: %S/test_errors.sh %s %t %flang_fc1
2! REQUIRES: shell
3! C1140 -- A statement that might result in the deallocation of a polymorphic
4! entity shall not appear within a DO CONCURRENT construct.
5module m1
6  ! Base type with scalar components
7  type :: Base
8    integer :: baseField1
9  end type
10
11  ! Child type so we can allocate polymorphic entities
12  type, extends(Base) :: ChildType
13    integer :: childField
14  end type
15
16  ! Type with a polymorphic, allocatable component
17  type, extends(Base) :: HasAllocPolyType
18    class(Base), allocatable :: allocPolyField
19  end type
20
21  ! Type with a allocatable, coarray component
22  type :: HasAllocCoarrayType
23    type(Base), allocatable, codimension[:] :: allocCoarrayField
24  end type
25
26  ! Type with a polymorphic, allocatable, coarray component
27  type :: HasAllocPolyCoarrayType
28    class(Base), allocatable, codimension[:] :: allocPolyCoarrayField
29  end type
30
31  ! Type with a polymorphic, pointer component
32  type, extends(Base) :: HasPointerPolyType
33    class(Base), pointer :: pointerPolyField
34  end type
35
36  class(Base), allocatable :: baseVar1
37  type(Base) :: baseVar2
38end module m1
39
40subroutine s1()
41  ! Test deallocation of polymorphic entities caused by block exit
42  use m1
43
44  block
45    ! The following should not cause problems
46    integer :: outerInt
47
48    ! The following are OK since they're not in a DO CONCURRENT
49    class(Base), allocatable :: outerAllocatablePolyVar
50    class(Base), allocatable, codimension[:] :: outerAllocatablePolyCoarray
51    type(HasAllocPolyType), allocatable  :: outerAllocatableWithAllocPoly
52    type(HasAllocPolyCoarrayType), allocatable :: outerAllocWithAllocPolyCoarray
53
54    do concurrent (i = 1:10)
55      ! The following should not cause problems
56      block
57        integer, allocatable :: blockInt
58      end block
59      block
60        ! Test polymorphic entities
61        ! OK because it's a pointer to a polymorphic entity
62        class(Base), pointer :: pointerPoly
63
64        ! OK because it's not polymorphic
65        integer, allocatable :: intAllocatable
66
67        ! OK because it's not polymorphic
68        type(Base), allocatable :: allocatableNonPolyBlockVar
69
70        ! Bad because it's polymorphic and allocatable
71        class(Base), allocatable :: allocatablePoly
72
73        ! OK because it has the SAVE attribute
74        class(Base), allocatable, save :: allocatablePolySave
75
76        ! Bad because it's polymorphic and allocatable
77        class(Base), allocatable, codimension[:] :: allocatablePolyCoarray
78
79        ! OK because it's not polymorphic and allocatable
80        type(Base), allocatable, codimension[:] :: allocatableCoarray
81
82        ! Bad because it has a allocatable polymorphic component
83        type(HasAllocPolyType), allocatable  :: allocatableWithAllocPoly
84
85        ! OK because the declared variable is not allocatable
86        type(HasAllocPolyType) :: nonAllocatableWithAllocPoly
87
88        ! OK because the declared variable is not allocatable
89        type(HasAllocPolyCoarrayType) :: nonAllocatableWithAllocPolyCoarray
90
91        ! Bad because even though the declared the allocatable component is a coarray
92        type(HasAllocPolyCoarrayType), allocatable :: allocWithAllocPolyCoarray
93
94        ! OK since it has no polymorphic component
95        type(HasAllocCoarrayType) :: nonAllocWithAllocCoarray
96
97        ! OK since it has no component that's polymorphic, oops
98        type(HasPointerPolyType), allocatable :: allocatableWithPointerPoly
99
100!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
101!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
102!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
103!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
104      end block
105    end do
106  end block
107
108end subroutine s1
109
110subroutine s2()
111  ! Test deallocation of a polymorphic entity cause by intrinsic assignment
112  use m1
113
114  class(Base), allocatable :: localVar
115  class(Base), allocatable :: localVar1
116  type(Base), allocatable :: localVar2
117
118  type(HasAllocPolyType), allocatable :: polyComponentVar
119  type(HasAllocPolyType), allocatable :: polyComponentVar1
120
121  type(HasAllocPolyType) :: nonAllocPolyComponentVar
122  type(HasAllocPolyType) :: nonAllocPolyComponentVar1
123  class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray
124  class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray1
125
126  class(Base), allocatable, codimension[:] :: allocPolyComponentVar
127  class(Base), allocatable, codimension[:] :: allocPolyComponentVar1
128
129  allocate(ChildType :: localVar)
130  allocate(ChildType :: localVar1)
131  allocate(Base :: localVar2)
132  allocate(polyComponentVar)
133  allocate(polyComponentVar1)
134  allocate(allocPolyCoarray)
135  allocate(allocPolyCoarray1)
136
137  ! These are OK because they're not in a DO CONCURRENT
138  localVar = localVar1
139  nonAllocPolyComponentVar = nonAllocPolyComponentVar1
140  polyComponentVar = polyComponentVar1
141  allocPolyCoarray = allocPolyCoarray1
142
143  do concurrent (i = 1:10)
144    ! Test polymorphic entities
145    ! Bad because localVar is allocatable and polymorphic, 10.2.1.3, par. 3
146!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
147    localVar = localVar1
148
149    ! The next one should be OK since localVar2 is not polymorphic
150    localVar2 = localVar1
151
152    ! Bad because the copying of the components causes deallocation
153!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
154    nonAllocPolyComponentVar = nonAllocPolyComponentVar1
155
156    ! Bad because possible deallocation a variable with a polymorphic component
157!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
158    polyComponentVar = polyComponentVar1
159
160    ! Bad because deallocation upon assignment happens with allocatable
161    ! entities, even if they're coarrays.  The noncoarray restriction only
162    ! applies to components
163!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
164    allocPolyCoarray = allocPolyCoarray1
165
166  end do
167end subroutine s2
168
169subroutine s3()
170  ! Test direct deallocation
171  use m1
172
173  class(Base), allocatable :: polyVar
174  type(Base), allocatable :: nonPolyVar
175  type(HasAllocPolyType), allocatable :: polyComponentVar
176  type(HasAllocPolyType), pointer :: pointerPolyComponentVar
177
178  allocate(ChildType:: polyVar)
179  allocate(nonPolyVar)
180  allocate(polyComponentVar)
181  allocate(pointerPolyComponentVar)
182
183  ! These are all good because they're not in a do concurrent
184  deallocate(polyVar)
185  allocate(polyVar)
186  deallocate(polyComponentVar)
187  allocate(polyComponentVar)
188  deallocate(pointerPolyComponentVar)
189  allocate(pointerPolyComponentVar)
190
191  do concurrent (i = 1:10)
192    ! Bad because deallocation of a polymorphic entity
193!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
194    deallocate(polyVar)
195
196    ! Bad, deallocation of an entity with a polymorphic component
197!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
198    deallocate(polyComponentVar)
199
200    ! Bad, deallocation of a pointer to an entity with a polymorphic component
201!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
202    deallocate(pointerPolyComponentVar)
203
204    ! Deallocation of a nonpolymorphic entity
205    deallocate(nonPolyVar)
206  end do
207end subroutine s3
208
209module m2
210  type :: impureFinal
211   contains
212    final :: impureSub
213  end type
214
215  type :: pureFinal
216   contains
217    final :: pureSub
218  end type
219
220 contains
221
222  impure subroutine impureSub(x)
223    type(impureFinal), intent(in) :: x
224  end subroutine
225
226  pure subroutine pureSub(x)
227    type(pureFinal), intent(in) :: x
228  end subroutine
229
230  subroutine s4()
231    type(impureFinal), allocatable :: ifVar, ifvar1
232    type(pureFinal), allocatable :: pfVar
233    allocate(ifVar)
234    allocate(ifVar1)
235    allocate(pfVar)
236
237    ! OK for an ordinary DO loop
238    do i = 1,10
239      if (i .eq. 1) deallocate(ifVar)
240    end do
241
242    ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT
243    ! This case does not work currently because the compiler's test for
244    ! HasImpureFinal() in .../lib/Semantics/tools.cc doesn't work correctly
245!    do concurrent (i = 1:10)
246!      if (i .eq. 1) deallocate(pfVar)
247!    end do
248
249    ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT
250    do concurrent (i = 1:10)
251          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by a DEALLOCATE statement not allowed in DO CONCURRENT
252      if (i .eq. 1) deallocate(ifVar)
253    end do
254
255    do concurrent (i = 1:10)
256      if (i .eq. 1) then
257        block
258          type(impureFinal), allocatable :: ifVar
259          allocate(ifVar)
260          ! Error here because exiting this scope causes the finalization of
261          !ifvar which causes the invocation of an IMPURE FINAL procedure
262          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by block exit not allowed in DO CONCURRENT
263        end block
264      end if
265    end do
266
267    do concurrent (i = 1:10)
268      if (i .eq. 1) then
269        ! Error here because the assignment statement causes the finalization
270        ! of ifvar which causes the invocation of an IMPURE FINAL procedure
271!ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by assignment not allowed in DO CONCURRENT
272        ifvar = ifvar1
273      end if
274    end do
275  end subroutine s4
276
277end module m2
278