e843d514b1
A few bits of semantic checking need a variant of the ResolveAssociations utility function that stops when hitting a construct entity for a type or class guard. This is necessary for cases like the bug below where the analysis is concerned with the type of the name in context, rather than its shape or storage or whatever. So add a flag to ResolveAssociations and GetAssociationRoot to make this happen, and use it at the appropriate call sites. Fixes https://github.com/llvm/llvm-project/issues/128608.
328 lines
11 KiB
Fortran
328 lines
11 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), save :: 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), save :: 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
|
|
|
|
class(*), allocatable :: unlimitedPoly
|
|
|
|
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
|
|
|
|
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
|
|
unlimitedPoly = 1
|
|
select type (unlimitedPoly)
|
|
type is (integer)
|
|
unlimitedPoly = 1 ! ok
|
|
class default
|
|
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
|
|
unlimitedPoly = 1
|
|
end select
|
|
|
|
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
|