flang/test/Semantics/doconcurrent08.f90

   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.
   4 module 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
  37 end module m1
  38
  39 subroutine 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
 107 end subroutine s1
 108
 109 subroutine 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
 166 end subroutine s2
 167
 168 subroutine 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
 206 end subroutine s3
 207
 208 module 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
 315 end module m2