1! RUN: %python %S/test_errors.py %s %flang_fc1 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 final :: impureSubRank1 213 final :: impureSubRank2 214 end type 215 216 type :: pureFinal 217 contains 218 final :: pureSub 219 end type 220 221 contains 222 223 impure subroutine impureSub(x) 224 type(impureFinal), intent(in) :: x 225 end subroutine 226 227 impure subroutine impureSubRank1(x) 228 type(impureFinal), intent(in) :: x(:) 229 end subroutine 230 231 impure subroutine impureSubRank2(x) 232 type(impureFinal), intent(in) :: x(:,:) 233 end subroutine 234 235 pure subroutine pureSub(x) 236 type(pureFinal), intent(in) :: x 237 end subroutine 238 239 subroutine s4() 240 type(impureFinal), allocatable :: ifVar, ifvar1 241 type(impureFinal), allocatable :: ifArr1(:), ifArr2(:,:) 242 type(impureFinal) :: if0 243 type(pureFinal), allocatable :: pfVar 244 allocate(ifVar) 245 allocate(ifVar1) 246 allocate(pfVar) 247 allocate(ifArr1(5), ifArr2(5,5)) 248 249 ! OK for an ordinary DO loop 250 do i = 1,10 251 if (i .eq. 1) deallocate(ifVar) 252 end do 253 254 ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT 255 do concurrent (i = 1:10) 256 if (i .eq. 1) deallocate(pfVar) 257 end do 258 259 ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT 260 do concurrent (i = 1:10) 261 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by a DEALLOCATE statement not allowed in DO CONCURRENT 262 if (i .eq. 1) deallocate(ifVar) 263 end do 264 265 do concurrent (i = 1:10) 266 if (i .eq. 1) then 267 block 268 type(impureFinal), allocatable :: ifVar 269 allocate(ifVar) 270 ! Error here because exiting this scope causes the finalization of 271 ! ifvar which causes the invocation of an IMPURE FINAL procedure 272 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by block exit not allowed in DO CONCURRENT 273 end block 274 end if 275 end do 276 277 do concurrent (i = 1:10) 278 if (i .eq. 1) then 279 ! Error here because the assignment statement causes the finalization 280 ! of ifvar which causes the invocation of an IMPURE FINAL procedure 281 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT 282 ifvar = ifvar1 283 end if 284 end do 285 286 do concurrent (i = 1:5) 287 if (i .eq. 1) then 288 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT 289 ifArr1(i) = if0 290 end if 291 end do 292 293 do concurrent (i = 1:5) 294 if (i .eq. 1) then 295 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT 296 ifArr1 = if0 297 end if 298 end do 299 300 do concurrent (i = 1:5) 301 if (i .eq. 1) then 302 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT 303 ifArr2(i,:) = if0 304 end if 305 end do 306 307 do concurrent (i = 1:5) 308 if (i .eq. 1) then 309 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank2' caused by assignment not allowed in DO CONCURRENT 310 ifArr2(:,:) = if0 311 end if 312 end do 313 end subroutine s4 314 315end module m2 316