xref: /llvm-project/flang/test/Semantics/doconcurrent08.f90 (revision 0c21377aeafc523bd4a8c40bd27e33498f3199f7)

! RUN: %python %S/test_errors.py %s %flang_fc1
! C1140 -- A statement that might result in the deallocation of a polymorphic
! entity shall not appear within a DO CONCURRENT construct.
module m1
  ! Base type with scalar components
  type :: Base
    integer :: baseField1
  end type

  ! Child type so we can allocate polymorphic entities
  type, extends(Base) :: ChildType
    integer :: childField
  end type

  ! Type with a polymorphic, allocatable component
  type, extends(Base) :: HasAllocPolyType
    class(Base), allocatable :: allocPolyField
  end type

  ! Type with a allocatable, coarray component
  type :: HasAllocCoarrayType
    type(Base), allocatable, codimension[:] :: allocCoarrayField
  end type

  ! Type with a polymorphic, allocatable, coarray component
  type :: HasAllocPolyCoarrayType
    class(Base), allocatable, codimension[:] :: allocPolyCoarrayField
  end type

  ! Type with a polymorphic, pointer component
  type, extends(Base) :: HasPointerPolyType
    class(Base), pointer :: pointerPolyField
  end type

  class(Base), allocatable :: baseVar1
  type(Base) :: baseVar2
end module m1

subroutine s1()
  ! Test deallocation of polymorphic entities caused by block exit
  use m1

  block
    ! The following should not cause problems
    integer :: outerInt

    ! The following are OK since they're not in a DO CONCURRENT
    class(Base), allocatable :: outerAllocatablePolyVar
    class(Base), allocatable, codimension[:] :: outerAllocatablePolyCoarray
    type(HasAllocPolyType), allocatable  :: outerAllocatableWithAllocPoly
    type(HasAllocPolyCoarrayType), allocatable :: outerAllocWithAllocPolyCoarray

    do concurrent (i = 1:10)
      ! The following should not cause problems
      block
        integer, allocatable :: blockInt
      end block
      block
        ! Test polymorphic entities
        ! OK because it's a pointer to a polymorphic entity
        class(Base), pointer :: pointerPoly

        ! OK because it's not polymorphic
        integer, allocatable :: intAllocatable

        ! OK because it's not polymorphic
        type(Base), allocatable :: allocatableNonPolyBlockVar

        ! Bad because it's polymorphic and allocatable
        class(Base), allocatable :: allocatablePoly

        ! OK because it has the SAVE attribute
        class(Base), allocatable, save :: allocatablePolySave

        ! Bad because it's polymorphic and allocatable
        class(Base), allocatable, codimension[:] :: allocatablePolyCoarray

        ! OK because it's not polymorphic and allocatable
        type(Base), allocatable, codimension[:] :: allocatableCoarray

        ! Bad because it has a allocatable polymorphic component
        type(HasAllocPolyType), allocatable  :: allocatableWithAllocPoly

        ! OK because the declared variable is not allocatable
        type(HasAllocPolyType) :: nonAllocatableWithAllocPoly

        ! OK because the declared variable is not allocatable
        type(HasAllocPolyCoarrayType) :: nonAllocatableWithAllocPolyCoarray

        ! Bad because even though the declared the allocatable component is a coarray
        type(HasAllocPolyCoarrayType), allocatable :: allocWithAllocPolyCoarray

        ! OK since it has no polymorphic component
        type(HasAllocCoarrayType) :: nonAllocWithAllocCoarray

        ! OK since it has no component that's polymorphic, oops
        type(HasPointerPolyType), allocatable :: allocatableWithPointerPoly

!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
      end block
    end do
  end block

end subroutine s1

subroutine s2()
  ! Test deallocation of a polymorphic entity cause by intrinsic assignment
  use m1

  class(Base), allocatable :: localVar
  class(Base), allocatable :: localVar1
  type(Base), allocatable :: localVar2

  type(HasAllocPolyType), allocatable :: polyComponentVar
  type(HasAllocPolyType), allocatable :: polyComponentVar1

  type(HasAllocPolyType) :: nonAllocPolyComponentVar
  type(HasAllocPolyType) :: nonAllocPolyComponentVar1
  class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray
  class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray1

  class(Base), allocatable, codimension[:] :: allocPolyComponentVar
  class(Base), allocatable, codimension[:] :: allocPolyComponentVar1

  allocate(ChildType :: localVar)
  allocate(ChildType :: localVar1)
  allocate(Base :: localVar2)
  allocate(polyComponentVar)
  allocate(polyComponentVar1)
  allocate(allocPolyCoarray)
  allocate(allocPolyCoarray1)

  ! These are OK because they're not in a DO CONCURRENT
  localVar = localVar1
  nonAllocPolyComponentVar = nonAllocPolyComponentVar1
  polyComponentVar = polyComponentVar1
  allocPolyCoarray = allocPolyCoarray1

  do concurrent (i = 1:10)
    ! Test polymorphic entities
    ! Bad because localVar is allocatable and polymorphic, 10.2.1.3, par. 3
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
    localVar = localVar1

    ! The next one should be OK since localVar2 is not polymorphic
    localVar2 = localVar1

    ! Bad because the copying of the components causes deallocation
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
    nonAllocPolyComponentVar = nonAllocPolyComponentVar1

    ! Bad because possible deallocation a variable with a polymorphic component
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
    polyComponentVar = polyComponentVar1

    ! Bad because deallocation upon assignment happens with allocatable
    ! entities, even if they're coarrays.  The noncoarray restriction only
    ! applies to components
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
    allocPolyCoarray = allocPolyCoarray1

  end do
end subroutine s2

subroutine s3()
  ! Test direct deallocation
  use m1

  class(Base), allocatable :: polyVar
  type(Base), allocatable :: nonPolyVar
  type(HasAllocPolyType), allocatable :: polyComponentVar
  type(HasAllocPolyType), pointer :: pointerPolyComponentVar

  allocate(ChildType:: polyVar)
  allocate(nonPolyVar)
  allocate(polyComponentVar)
  allocate(pointerPolyComponentVar)

  ! These are all good because they're not in a do concurrent
  deallocate(polyVar)
  allocate(polyVar)
  deallocate(polyComponentVar)
  allocate(polyComponentVar)
  deallocate(pointerPolyComponentVar)
  allocate(pointerPolyComponentVar)

  do concurrent (i = 1:10)
    ! Bad because deallocation of a polymorphic entity
!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
    deallocate(polyVar)

    ! Bad, deallocation of an entity with a polymorphic component
!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
    deallocate(polyComponentVar)

    ! Bad, deallocation of a pointer to an entity with a polymorphic component
!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
    deallocate(pointerPolyComponentVar)

    ! Deallocation of a nonpolymorphic entity
    deallocate(nonPolyVar)
  end do
end subroutine s3

module m2
  type :: impureFinal
   contains
    final :: impureSub
    final :: impureSubRank1
    final :: impureSubRank2
  end type

  type :: pureFinal
   contains
    final :: pureSub
  end type

 contains

  impure subroutine impureSub(x)
    type(impureFinal), intent(in) :: x
  end subroutine

  impure subroutine impureSubRank1(x)
    type(impureFinal), intent(in) :: x(:)
  end subroutine

  impure subroutine impureSubRank2(x)
    type(impureFinal), intent(in) :: x(:,:)
  end subroutine

  pure subroutine pureSub(x)
    type(pureFinal), intent(in) :: x
  end subroutine

  subroutine s4()
    type(impureFinal), allocatable :: ifVar, ifvar1
    type(impureFinal), allocatable :: ifArr1(:), ifArr2(:,:)
    type(impureFinal) :: if0
    type(pureFinal), allocatable :: pfVar
    allocate(ifVar)
    allocate(ifVar1)
    allocate(pfVar)
    allocate(ifArr1(5), ifArr2(5,5))

    ! OK for an ordinary DO loop
    do i = 1,10
      if (i .eq. 1) deallocate(ifVar)
    end do

    ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT
    do concurrent (i = 1:10)
      if (i .eq. 1) deallocate(pfVar)
    end do

    ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT
    do concurrent (i = 1:10)
      !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by a DEALLOCATE statement not allowed in DO CONCURRENT
      if (i .eq. 1) deallocate(ifVar)
    end do

    do concurrent (i = 1:10)
      if (i .eq. 1) then
        block
          type(impureFinal), allocatable :: ifVar
          allocate(ifVar)
          ! Error here because exiting this scope causes the finalization of
          ! ifvar which causes the invocation of an IMPURE FINAL procedure
          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by block exit not allowed in DO CONCURRENT
        end block
      end if
    end do

    do concurrent (i = 1:10)
      if (i .eq. 1) then
        ! Error here because the assignment statement causes the finalization
        ! of ifvar which causes the invocation of an IMPURE FINAL procedure
        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT
        ifvar = ifvar1
      end if
    end do

    do concurrent (i = 1:5)
      if (i .eq. 1) then
        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT
        ifArr1(i) = if0
      end if
    end do

    do concurrent (i = 1:5)
      if (i .eq. 1) then
        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT
        ifArr1 = if0
      end if
    end do

    do concurrent (i = 1:5)
      if (i .eq. 1) then
        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT
        ifArr2(i,:) = if0
      end if
    end do

    do concurrent (i = 1:5)
      if (i .eq. 1) then
        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank2' caused by assignment not allowed in DO CONCURRENT
        ifArr2(:,:) = if0
      end if
    end do
  end subroutine s4

end module m2