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