[flang-commits] [PATCH] D146585: [flang] Catch impure defined assignments in DO CONCURRENT

[Peter Klausler via Phabricator via flang-commits]

This revision was automatically updated to reflect the committed changes.
Closed by commit rGb0f02cee2b5b: [flang] Catch impure defined assignments in DO CONCURRENT (authored by klausler).

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D146585/new/

https://reviews.llvm.org/D146585

Files:
  flang/lib/Semantics/check-do-forall.cpp
  flang/test/Semantics/doconcurrent01.f90


Index: flang/test/Semantics/doconcurrent01.f90
===================================================================
--- flang/test/Semantics/doconcurrent01.f90
+++ flang/test/Semantics/doconcurrent01.f90
@@ -237,3 +237,34 @@
     end function pureFunc
 
 end subroutine s7
+
+module m8
+  type t
+   contains
+    procedure tbpAssign
+    generic :: assignment(=) => tbpAssign
+  end type
+  interface assignment(=)
+    module procedure nonTbpAssign
+  end interface
+ contains
+  impure elemental subroutine tbpAssign(to, from)
+    class(t), intent(out) :: to
+    class(t), intent(in) :: from
+    print *, 'impure due to I/O'
+  end
+  impure elemental subroutine nonTbpAssign(to, from)
+    type(t), intent(out) :: to
+    integer, intent(in) :: from
+    print *, 'impure due to I/O'
+  end
+  subroutine test
+    type(t) x, y
+    do concurrent (j=1:1)
+      !ERROR: The defined assignment subroutine 'tbpassign' is not pure
+      x = y
+      !ERROR: The defined assignment subroutine 'nontbpassign' is not pure
+      x = 666
+    end do
+  end
+end
Index: flang/lib/Semantics/check-do-forall.cpp
===================================================================
--- flang/lib/Semantics/check-do-forall.cpp
+++ flang/lib/Semantics/check-do-forall.cpp
@@ -219,6 +219,16 @@
         SayDeallocateWithImpureFinal(*entity, reason);
       }
     }
+    if (const auto *assignment{GetAssignment(stmt)}) {
+      if (const auto *call{
+              std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
+        if (auto bad{FindImpureCall(context_.foldingContext(), *call)}) {
+          context_.Say(currentStatementSourcePosition_,
+              "The defined assignment subroutine '%s' is not pure"_err_en_US,
+              *bad);
+        }
+      }
+    }
   }
 
   // Deallocation from a DEALLOCATE statement
@@ -431,10 +441,10 @@
   }
 
   void Check(const parser::ForallAssignmentStmt &stmt) {
-    const evaluate::Assignment *assignment{common::visit(
-        common::visitors{[&](const auto &x) { return GetAssignment(x); }},
-        stmt.u)};
-    if (assignment) {
+    if (const evaluate::Assignment *
+        assignment{common::visit(
+            common::visitors{[&](const auto &x) { return GetAssignment(x); }},
+            stmt.u)}) {
       CheckForallIndexesUsed(*assignment);
       CheckForImpureCall(assignment->lhs);
       CheckForImpureCall(assignment->rhs);


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D146585.508853.patch
Type: text/x-patch
Size: 2402 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20230328/e42568b0/attachment-0001.bin>