diff options
author | Kelvin Li <kkwli@users.noreply.github.com> | 2024-03-18 10:59:47 -0400 |
---|---|---|
committer | GitHub <noreply@github.com> | 2024-03-18 10:59:47 -0400 |
commit | 0c21377aeafc523bd4a8c40bd27e33498f3199f7 (patch) | |
tree | bf90704e2d12808c46f274c67f200b93ed67e105 | |
parent | 487f356b20860a3eeb29b836483c639735f9393c (diff) | |
download | llvm-0c21377aeafc523bd4a8c40bd27e33498f3199f7.zip llvm-0c21377aeafc523bd4a8c40bd27e33498f3199f7.tar.gz llvm-0c21377aeafc523bd4a8c40bd27e33498f3199f7.tar.bz2 |
[flang] Diagnose the impure procedure reference in finalization according to the rank of the entity (#85475)
Use the rank of the array section to determine which final procedure
would be called in diagnosing whether that procedure is impure or not.
-rw-r--r-- | flang/include/flang/Semantics/tools.h | 3 | ||||
-rw-r--r-- | flang/lib/Semantics/check-do-forall.cpp | 7 | ||||
-rw-r--r-- | flang/lib/Semantics/tools.cpp | 13 | ||||
-rw-r--r-- | flang/test/Semantics/doconcurrent08.f90 | 49 |
4 files changed, 59 insertions, 13 deletions
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index df66e1a..dc3cd6c 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -180,7 +180,8 @@ const Symbol *IsFinalizable(const Symbol &, const Symbol *IsFinalizable(const DerivedTypeSpec &, std::set<const DerivedTypeSpec *> * = nullptr, bool withImpureFinalizer = false, std::optional<int> rank = std::nullopt); -const Symbol *HasImpureFinal(const Symbol &); +const Symbol *HasImpureFinal( + const Symbol &, std::optional<int> rank = std::nullopt); // Is this type finalizable or does it contain any polymorphic allocatable // ultimate components? bool MayRequireFinalization(const DerivedTypeSpec &derived); diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp index 4e8578d..36340a4 100644 --- a/flang/lib/Semantics/check-do-forall.cpp +++ b/flang/lib/Semantics/check-do-forall.cpp @@ -220,8 +220,11 @@ public: if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) { SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason); } - if (const Symbol * impure{HasImpureFinal(*entity)}) { - SayDeallocateWithImpureFinal(*entity, reason, *impure); + if (const auto *assignment{GetAssignment(stmt)}) { + const auto &lhs{assignment->lhs}; + if (const Symbol * impure{HasImpureFinal(*entity, lhs.Rank())}) { + SayDeallocateWithImpureFinal(*entity, reason, *impure); + } } } if (const auto *assignment{GetAssignment(stmt)}) { diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index bf999b0..0484baa 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -827,15 +827,18 @@ static const Symbol *HasImpureFinal( return IsFinalizable(derived, nullptr, /*withImpureFinalizer=*/true, rank); } -const Symbol *HasImpureFinal(const Symbol &original) { +const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) { const Symbol &symbol{ResolveAssociations(original)}; if (symbol.has<ObjectEntityDetails>()) { if (const DeclTypeSpec * symType{symbol.GetType()}) { if (const DerivedTypeSpec * derived{symType->AsDerived()}) { - // finalizable assumed-rank not allowed (C839) - return evaluate::IsAssumedRank(symbol) - ? nullptr - : HasImpureFinal(*derived, symbol.Rank()); + if (evaluate::IsAssumedRank(symbol)) { + // finalizable assumed-rank not allowed (C839) + return nullptr; + } else { + int actualRank{rank.value_or(symbol.Rank())}; + return HasImpureFinal(*derived, actualRank); + } } } } diff --git a/flang/test/Semantics/doconcurrent08.f90 b/flang/test/Semantics/doconcurrent08.f90 index 41cd71e..52b38274 100644 --- a/flang/test/Semantics/doconcurrent08.f90 +++ b/flang/test/Semantics/doconcurrent08.f90 @@ -209,6 +209,8 @@ module m2 type :: impureFinal contains final :: impureSub + final :: impureSubRank1 + final :: impureSubRank2 end type type :: pureFinal @@ -222,16 +224,27 @@ module m2 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 @@ -239,11 +252,9 @@ module m2 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 + 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) @@ -271,6 +282,34 @@ module m2 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 |