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

[via flang-commits]

Author: Kelvin Li
Date: 2024-03-18T21:35:56-04:00
New Revision: a5f576e5961ecc099bd7ccf8565da090edc84b0d

URL: https://github.com/llvm/llvm-project/commit/a5f576e5961ecc099bd7ccf8565da090edc84b0d
DIFF: https://github.com/llvm/llvm-project/commit/a5f576e5961ecc099bd7ccf8565da090edc84b0d.diff

LOG: [flang] Diagnose calling impure final procedure due to finalization in FORALL (#85685)

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

Added: 
    flang/test/Semantics/forall02.f90

Modified: 
    flang/lib/Semantics/check-do-forall.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 36340a4c5259a7..51f536f3d77231 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -438,6 +438,18 @@ 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
+