328 lines · plain
1! RUN: %python %S/test_errors.py %s %flang_fc12! C1140 -- A statement that might result in the deallocation of a polymorphic 3! entity shall not appear within a DO CONCURRENT construct.4module m15 ! Base type with scalar components6 type :: Base7 integer :: baseField18 end type9 10 ! Child type so we can allocate polymorphic entities11 type, extends(Base) :: ChildType12 integer :: childField13 end type14 15 ! Type with a polymorphic, allocatable component16 type, extends(Base) :: HasAllocPolyType17 class(Base), allocatable :: allocPolyField18 end type19 20 ! Type with a allocatable, coarray component21 type :: HasAllocCoarrayType22 type(Base), allocatable, codimension[:] :: allocCoarrayField23 end type24 25 ! Type with a polymorphic, allocatable, coarray component26 type :: HasAllocPolyCoarrayType27 class(Base), allocatable, codimension[:] :: allocPolyCoarrayField28 end type29 30 ! Type with a polymorphic, pointer component31 type, extends(Base) :: HasPointerPolyType32 class(Base), pointer :: pointerPolyField33 end type34 35 class(Base), allocatable :: baseVar136 type(Base) :: baseVar237end module m138 39subroutine s1()40 ! Test deallocation of polymorphic entities caused by block exit41 use m142 43 block44 ! The following should not cause problems45 integer :: outerInt46 47 ! The following are OK since they're not in a DO CONCURRENT48 class(Base), allocatable :: outerAllocatablePolyVar49 class(Base), allocatable, codimension[:] :: outerAllocatablePolyCoarray50 type(HasAllocPolyType), allocatable :: outerAllocatableWithAllocPoly51 type(HasAllocPolyCoarrayType), allocatable :: outerAllocWithAllocPolyCoarray52 53 do concurrent (i = 1:10)54 ! The following should not cause problems55 block56 integer, allocatable :: blockInt57 end block58 block59 ! Test polymorphic entities60 ! OK because it's a pointer to a polymorphic entity61 class(Base), pointer :: pointerPoly62 63 ! OK because it's not polymorphic64 integer, allocatable :: intAllocatable65 66 ! OK because it's not polymorphic67 type(Base), allocatable :: allocatableNonPolyBlockVar68 69 ! Bad because it's polymorphic and allocatable70 class(Base), allocatable :: allocatablePoly71 72 ! OK because it has the SAVE attribute73 class(Base), allocatable, save :: allocatablePolySave74 75 ! Bad because it's polymorphic and allocatable76 class(Base), allocatable, codimension[:] :: allocatablePolyCoarray77 78 ! OK because it's not polymorphic and allocatable79 type(Base), allocatable, codimension[:] :: allocatableCoarray80 81 ! Bad because it has a allocatable polymorphic component82 type(HasAllocPolyType), allocatable :: allocatableWithAllocPoly83 84 ! OK because the declared variable is not allocatable85 type(HasAllocPolyType) :: nonAllocatableWithAllocPoly86 87 ! OK because the declared variable is not allocatable88 type(HasAllocPolyCoarrayType), save :: nonAllocatableWithAllocPolyCoarray89 90 ! Bad because even though the declared the allocatable component is a coarray91 type(HasAllocPolyCoarrayType), allocatable :: allocWithAllocPolyCoarray92 93 ! OK since it has no polymorphic component94 type(HasAllocCoarrayType), save :: nonAllocWithAllocCoarray95 96 ! OK since it has no component that's polymorphic, oops97 type(HasPointerPolyType), allocatable :: allocatableWithPointerPoly98 99!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT100!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT101!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT102!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT103 end block104 end do105 end block106 107end subroutine s1108 109subroutine s2()110 ! Test deallocation of a polymorphic entity cause by intrinsic assignment111 use m1112 113 class(Base), allocatable :: localVar114 class(Base), allocatable :: localVar1115 type(Base), allocatable :: localVar2116 117 type(HasAllocPolyType), allocatable :: polyComponentVar118 type(HasAllocPolyType), allocatable :: polyComponentVar1119 120 type(HasAllocPolyType) :: nonAllocPolyComponentVar121 type(HasAllocPolyType) :: nonAllocPolyComponentVar1122 class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray123 class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray1124 125 class(Base), allocatable, codimension[:] :: allocPolyComponentVar126 class(Base), allocatable, codimension[:] :: allocPolyComponentVar1127 128 class(*), allocatable :: unlimitedPoly129 130 allocate(ChildType :: localVar)131 allocate(ChildType :: localVar1)132 allocate(Base :: localVar2)133 allocate(polyComponentVar)134 allocate(polyComponentVar1)135 allocate(allocPolyCoarray)136 allocate(allocPolyCoarray1)137 138 ! These are OK because they're not in a DO CONCURRENT139 localVar = localVar1140 nonAllocPolyComponentVar = nonAllocPolyComponentVar1141 polyComponentVar = polyComponentVar1142 allocPolyCoarray = allocPolyCoarray1143 144 do concurrent (i = 1:10)145 ! Test polymorphic entities146 ! Bad because localVar is allocatable and polymorphic, 10.2.1.3, par. 3147!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT148 localVar = localVar1149 150 ! The next one should be OK since localVar2 is not polymorphic151 localVar2 = localVar1152 153 ! Bad because the copying of the components causes deallocation154!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT155 nonAllocPolyComponentVar = nonAllocPolyComponentVar1156 157 ! Bad because possible deallocation a variable with a polymorphic component158!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT159 polyComponentVar = polyComponentVar1160 161 ! Bad because deallocation upon assignment happens with allocatable162 ! entities, even if they're coarrays. The noncoarray restriction only163 ! applies to components164!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT165 allocPolyCoarray = allocPolyCoarray1166 167!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT168 unlimitedPoly = 1169 select type (unlimitedPoly)170 type is (integer)171 unlimitedPoly = 1 ! ok172 class default173!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT174 unlimitedPoly = 1175 end select176 177 end do178end subroutine s2179 180subroutine s3()181 ! Test direct deallocation182 use m1183 184 class(Base), allocatable :: polyVar185 type(Base), allocatable :: nonPolyVar186 type(HasAllocPolyType), allocatable :: polyComponentVar187 type(HasAllocPolyType), pointer :: pointerPolyComponentVar188 189 allocate(ChildType:: polyVar)190 allocate(nonPolyVar)191 allocate(polyComponentVar)192 allocate(pointerPolyComponentVar)193 194 ! These are all good because they're not in a do concurrent195 deallocate(polyVar)196 allocate(polyVar)197 deallocate(polyComponentVar)198 allocate(polyComponentVar)199 deallocate(pointerPolyComponentVar)200 allocate(pointerPolyComponentVar)201 202 do concurrent (i = 1:10)203 ! Bad because deallocation of a polymorphic entity204!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT205 deallocate(polyVar)206 207 ! Bad, deallocation of an entity with a polymorphic component208!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT209 deallocate(polyComponentVar)210 211 ! Bad, deallocation of a pointer to an entity with a polymorphic component212!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT213 deallocate(pointerPolyComponentVar)214 215 ! Deallocation of a nonpolymorphic entity216 deallocate(nonPolyVar)217 end do218end subroutine s3219 220module m2221 type :: impureFinal222 contains223 final :: impureSub224 final :: impureSubRank1225 final :: impureSubRank2226 end type227 228 type :: pureFinal229 contains230 final :: pureSub231 end type232 233 contains234 235 impure subroutine impureSub(x)236 type(impureFinal), intent(in) :: x237 end subroutine238 239 impure subroutine impureSubRank1(x)240 type(impureFinal), intent(in) :: x(:)241 end subroutine242 243 impure subroutine impureSubRank2(x)244 type(impureFinal), intent(in) :: x(:,:)245 end subroutine246 247 pure subroutine pureSub(x)248 type(pureFinal), intent(in) :: x249 end subroutine250 251 subroutine s4()252 type(impureFinal), allocatable :: ifVar, ifvar1253 type(impureFinal), allocatable :: ifArr1(:), ifArr2(:,:)254 type(impureFinal) :: if0255 type(pureFinal), allocatable :: pfVar256 allocate(ifVar)257 allocate(ifVar1)258 allocate(pfVar)259 allocate(ifArr1(5), ifArr2(5,5))260 261 ! OK for an ordinary DO loop262 do i = 1,10263 if (i .eq. 1) deallocate(ifVar)264 end do265 266 ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT267 do concurrent (i = 1:10)268 if (i .eq. 1) deallocate(pfVar)269 end do270 271 ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT272 do concurrent (i = 1:10)273 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by a DEALLOCATE statement not allowed in DO CONCURRENT274 if (i .eq. 1) deallocate(ifVar)275 end do276 277 do concurrent (i = 1:10)278 if (i .eq. 1) then279 block280 type(impureFinal), allocatable :: ifVar281 allocate(ifVar)282 ! Error here because exiting this scope causes the finalization of283 ! ifvar which causes the invocation of an IMPURE FINAL procedure284 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by block exit not allowed in DO CONCURRENT285 end block286 end if287 end do288 289 do concurrent (i = 1:10)290 if (i .eq. 1) then291 ! Error here because the assignment statement causes the finalization292 ! of ifvar which causes the invocation of an IMPURE FINAL procedure293 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT294 ifvar = ifvar1295 end if296 end do297 298 do concurrent (i = 1:5)299 if (i .eq. 1) then300 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT301 ifArr1(i) = if0302 end if303 end do304 305 do concurrent (i = 1:5)306 if (i .eq. 1) then307 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT308 ifArr1 = if0309 end if310 end do311 312 do concurrent (i = 1:5)313 if (i .eq. 1) then314 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT315 ifArr2(i,:) = if0316 end if317 end do318 319 do concurrent (i = 1:5)320 if (i .eq. 1) then321 !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank2' caused by assignment not allowed in DO CONCURRENT322 ifArr2(:,:) = if0323 end if324 end do325 end subroutine s4326 327end module m2328