[flang-commits] [flang] b0f02ce - [flang] Catch impure defined assignments in DO CONCURRENT

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-03-27T17:25:26-07:00
New Revision: b0f02cee2b5b9a767705db9b9aa0663b49742c4e

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

LOG: [flang] Catch impure defined assignments in DO CONCURRENT

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.

Differential Revision: https://reviews.llvm.org/D146585

Added: 
    

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

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 65b2986139b4..cf2a2c26d9c5 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -219,6 +219,16 @@ class DoConcurrentBodyEnforce {
         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 @@ class DoContext {
   }
 
   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);

diff  --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90
index c44c1e27528f..0f4e13da2290 100644
--- a/flang/test/Semantics/doconcurrent01.f90
+++ b/flang/test/Semantics/doconcurrent01.f90
@@ -237,3 +237,34 @@ pure integer function pureFunc()
     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