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

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added subscribers: sunshaoce, jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

The semantic checking of DO CONCURRENT bodies looks only at the
parse tree, not the typed expressions produced from it, so it
misses calls to defined assignment subroutines that arise from
assignment statements that resolve via generic interfaces into
subroutine calls.  Extend the checking to peek into the typed
assignment operations left on the parse tree by semantics.


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
@@ -232,3 +232,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.507154.patch
Type: text/x-patch
Size: 2402 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20230321/1d1c7400/attachment-0001.bin>