[flang-commits] [flang] [flang] Diagnose calling impure final procedure due to finalization in FORALL (PR #85685)

[Kelvin Li via flang-commits]

https://github.com/kkwli updated https://github.com/llvm/llvm-project/pull/85685

>From 1a065aba0725399e47ae4a798ec678a5ac23a691 Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Fri, 1 Mar 2024 10:34:47 -0500
Subject: [PATCH 1/2] [flang] Diagnose calling impure final procedure due to
 finalization in FORALL

This patch checks the LHS of an assignment in a FORALL loop and
diagnoses if any impure final procedure is called.
---
 flang/lib/Semantics/check-do-forall.cpp | 13 +++++
 flang/test/Semantics/forall02.f90       | 67 +++++++++++++++++++++++++
 2 files changed, 80 insertions(+)
 create mode 100644 flang/test/Semantics/forall02.f90

diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 36340a4c5259a7..67a7d63d06aad5 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -438,6 +438,19 @@ class DoContext {
       CheckForallIndexesUsed(*assignment);
       CheckForImpureCall(assignment->lhs);
       CheckForImpureCall(assignment->rhs);
+
+      if (IsVariable(assignment->lhs)) {
+        if (const Symbol *symbol{GetLastSymbol(assignment->lhs)}) {
+          if (auto impureFinal{
+                  HasImpureFinal(*symbol, assignment->lhs.Rank())}) {
+            context_.SayWithDecl(
+                *symbol, parser::FindSourceLocation(stmt),
+                "Impure procedure '%s' is referenced by finalization in a %s"_err_en_US,
+                impureFinal->name(), LoopKindName());
+          }
+        }
+      }
+
       if (const auto *proc{
               std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
         CheckForImpureCall(*proc);
diff --git a/flang/test/Semantics/forall02.f90 b/flang/test/Semantics/forall02.f90
new file mode 100644
index 00000000000000..c4f4311a175a3e
--- /dev/null
+++ b/flang/test/Semantics/forall02.f90
@@ -0,0 +1,67 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module m1
+  type :: impureFinal
+  contains
+    final :: impureSub
+    final :: impureSubRank1
+    final :: impureSubRank2
+  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
+
+  subroutine s1()
+    implicit none
+    integer :: i
+    type(impureFinal), allocatable :: ifVar, ifvar1
+    type(impureFinal), allocatable :: ifArr1(:), ifArr2(:,:)
+    type(impureFinal) :: if0
+    integer a(10)
+    allocate(ifVar)
+    allocate(ifVar1)
+    allocate(ifArr1(5), ifArr2(5,5))
+
+    ! Error to invoke an IMPURE FINAL procedure in a FORALL
+    forall (i = 1:10)
+      !WARNING: FORALL index variable 'i' not used on left-hand side of assignment
+      !ERROR: Impure procedure 'impuresub' is referenced by finalization in a FORALL
+      ifvar = ifvar1
+    end forall
+
+    forall (i = 1:5)
+      !ERROR: Impure procedure 'impuresub' is referenced by finalization in a FORALL
+      ifArr1(i) = if0
+    end forall
+
+    forall (i = 1:5)
+      !WARNING: FORALL index variable 'i' not used on left-hand side of assignment
+      !ERROR: Impure procedure 'impuresubrank1' is referenced by finalization in a FORALL
+      ifArr1 = if0
+    end forall
+
+    forall (i = 1:5)
+      !ERROR: Impure procedure 'impuresubrank1' is referenced by finalization in a FORALL
+      ifArr2(i,:) = if0
+    end forall
+
+    forall (i = 1:5)
+      !WARNING: FORALL index variable 'i' not used on left-hand side of assignment
+      !ERROR: Impure procedure 'impuresubrank2' is referenced by finalization in a FORALL
+      ifArr2(:,:) = if0
+    end forall
+  end subroutine
+
+end module m1
+

>From e52c30165fd6b3680f84c03315e1e4110a0b039b Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Mon, 18 Mar 2024 15:57:04 -0400
Subject: [PATCH 2/2] fix format

---
 flang/lib/Semantics/check-do-forall.cpp | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 67a7d63d06aad5..51f536f3d77231 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -440,11 +440,10 @@ class DoContext {
       CheckForImpureCall(assignment->rhs);
 
       if (IsVariable(assignment->lhs)) {
-        if (const Symbol *symbol{GetLastSymbol(assignment->lhs)}) {
+        if (const Symbol * symbol{GetLastSymbol(assignment->lhs)}) {
           if (auto impureFinal{
                   HasImpureFinal(*symbol, assignment->lhs.Rank())}) {
-            context_.SayWithDecl(
-                *symbol, parser::FindSourceLocation(stmt),
+            context_.SayWithDecl(*symbol, parser::FindSourceLocation(stmt),
                 "Impure procedure '%s' is referenced by finalization in a %s"_err_en_US,
                 impureFinal->name(), LoopKindName());
           }