[flang-commits] [flang] [flang] Diagnose the impure procedure reference in finalization according to the rank of the entity (PR #85475)
via flang-commits
flang-commits at lists.llvm.org
Fri Mar 15 15:12:16 PDT 2024
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
Author: Kelvin Li (kkwli)
<details>
<summary>Changes</summary>
Use the rank of the array section to determine which final procedure would be called in diagnosing whether that procedure is impure or not.
---
Full diff: https://github.com/llvm/llvm-project/pull/85475.diff
4 Files Affected:
- (modified) flang/include/flang/Semantics/tools.h (+1-1)
- (modified) flang/lib/Semantics/check-do-forall.cpp (+5-2)
- (modified) flang/lib/Semantics/tools.cpp (+11-5)
- (modified) flang/test/Semantics/doconcurrent08.f90 (+44-5)
``````````diff
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index df66e1adb55023..f728291103049b 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -180,7 +180,7 @@ 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 4e8578d0e1daff..9dfc3092856102 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -220,8 +220,11 @@ class DoConcurrentBodyEnforce {
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 bf999b090419c6..3636b62bfef8c9 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -827,15 +827,21 @@ 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 = symbol.Rank();
+ if (rank) {
+ actualRank = rank.value();
+ }
+ return HasImpureFinal(*derived, actualRank);
+ }
}
}
}
diff --git a/flang/test/Semantics/doconcurrent08.f90 b/flang/test/Semantics/doconcurrent08.f90
index 41cd71e233d0d3..52b382741d0731 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 @@ 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
@@ -239,11 +252,9 @@ subroutine s4()
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 @@ subroutine s4()
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
``````````
</details>
https://github.com/llvm/llvm-project/pull/85475
More information about the flang-commits
mailing list