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   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
 276 end module m2