[flang] Diagnose the impure procedure reference in finalization according to the rank of the entity

[kkwli]

Use the rank of the array section to determine which final procedure would be called in diagnosing whether that procedure is impure or not.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Kelvin Li (kkwli)

Changes

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 --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

[github-actions]

✅ With the latest revision this PR passed the C/C++ code formatter.

[kkwli]

Thanks for the review.