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