e9a8ab004c
Many semantic checks for constraints related to PURE subprograms can be implemented in terms of Semantics' "definable.h" utilities, slightly expanded. Replace some particular PURE constraint checks with calls to WhyNotDefinable(), except for cases that had better specific error messages, and start checking some missing constraints with DEALLOCATE statements and local variable declarations. Differential Revision: https://reviews.llvm.org/D147389
277 lines
9.4 KiB
Fortran
277 lines
9.4 KiB
Fortran
! 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
|
|
end type
|
|
|
|
type :: pureFinal
|
|
contains
|
|
final :: pureSub
|
|
end type
|
|
|
|
contains
|
|
|
|
impure subroutine impureSub(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(pureFinal), allocatable :: pfVar
|
|
allocate(ifVar)
|
|
allocate(ifVar1)
|
|
allocate(pfVar)
|
|
|
|
! 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
|
|
! This case does not work currently because the compiler's test for
|
|
! HasImpureFinal() in .../lib/Semantics/tools.cc doesn't work correctly
|
|
! 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
|
|
end subroutine s4
|
|
|
|
end module m2
|