[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 created https://github.com/llvm/llvm-project/pull/85685

This patch checks the LHS of an assignment in a FORALL loop and diagnoses if any impure final procedure is called.

>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] [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
+