[flang] Catch impure specifics called in DO CONCURRENT

Rework the code used to check for calls to impure procedures in DO CONCURRENT
constructs.  The current code wasn't checking the representation of the
procedure references in the strongly typed expressions, so it was missing
calls to impure subprograms made via generic interfaces.  While here,
improve error messages, and fix some minor issues exposed by testing the
improved checks.

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

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 04cc7b3..c6f32c0 100644 (file)
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2361,6 +2361,10 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     attrs.set(characteristics::Procedure::Attr::Elemental);
   }
   if (call.isSubroutineCall) {
+    if (intrinsicClass == IntrinsicClass::pureSubroutine /* MOVE_ALLOC */ ||
+        intrinsicClass == IntrinsicClass::elementalSubroutine /* MVBITS */) {
+      attrs.set(characteristics::Procedure::Attr::Pure);
+    }
     return SpecificCall{
         SpecificIntrinsic{
             name, characteristics::Procedure{std::move(dummyArgs), attrs}},

diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 8ba301d..a1ed466 100644 (file)
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -12,6 +12,7 @@
 #include "flang/Evaluate/call.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Evaluate/tools.h"
+#include "flang/Evaluate/traverse.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Parser/tools.h"
@@ -90,9 +91,16 @@ public:
       : context_{context}, doConcurrentSourcePosition_{
                                doConcurrentSourcePosition} {}
   std::set<parser::Label> labels() { return labels_; }
-  template <typename T> bool Pre(const T &) { return true; }
-  template <typename T> void Post(const T &) {}
-
+  template <typename T> bool Pre(const T &x) {
+    if (const auto *expr{GetExpr(context_, x)}) {
+      if (auto bad{FindImpureCall(context_.foldingContext(), *expr)}) {
+        context_.Say(currentStatementSourcePosition_,
+            "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
+            *bad);
+      }
+    }
+    return true;
+  }
   template <typename T> bool Pre(const parser::Statement<T> &statement) {
     currentStatementSourcePosition_ = statement.source;
     if (statement.label.has_value()) {
@@ -100,11 +108,21 @@ public:
     }
     return true;
   }
-
   template <typename T> bool Pre(const parser::UnlabeledStatement<T> &stmt) {
     currentStatementSourcePosition_ = stmt.source;
     return true;
   }
+  bool Pre(const parser::CallStmt &x) {
+    if (x.typedCall.get()) {
+      if (auto bad{FindImpureCall(context_.foldingContext(), *x.typedCall)}) {
+        context_.Say(currentStatementSourcePosition_,
+            "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
+            *bad);
+      }
+    }
+    return true;
+  }
+  template <typename T> void Post(const T &) {}
 
   // C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
   // Deallocation can be caused by exiting a block that declares an allocatable
@@ -271,12 +289,6 @@ public:
   // not pure, and impure procedures are caught by checks for constraint C1139
   void Post(const parser::ProcedureDesignator &procedureDesignator) {
     if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
-      if (name->symbol && !IsPureProcedure(*name->symbol)) {
-        SayWithDo(context_, currentStatementSourcePosition_,
-            "Call to an impure procedure is not allowed in DO"
-            " CONCURRENT"_err_en_US,
-            doConcurrentSourcePosition_);
-      }
       if (name->symbol &&
           fromScope(*name->symbol, "__fortran_ieee_exceptions"s)) {
         if (name->source == "ieee_set_halting_mode") {
@@ -286,16 +298,6 @@ public:
               doConcurrentSourcePosition_);
         }
       }
-    } else {
-      // C1139: this a procedure component
-      auto &component{std::get<parser::ProcComponentRef>(procedureDesignator.u)
-                          .v.thing.component};
-      if (component.symbol && !IsPureProcedure(*component.symbol)) {
-        SayWithDo(context_, currentStatementSourcePosition_,
-            "Call to an impure procedure component is not allowed"
-            " in DO CONCURRENT"_err_en_US,
-            doConcurrentSourcePosition_);
-      }
     }
   }
 
@@ -411,13 +413,11 @@ public:
   void Check(const parser::DoConstruct &doConstruct) {
     if (doConstruct.IsDoConcurrent()) {
       CheckDoConcurrent(doConstruct);
-      return;
-    }
-    if (doConstruct.IsDoNormal()) {
+    } else if (doConstruct.IsDoNormal()) {
       CheckDoNormal(doConstruct);
-      return;
+    } else {
+      // TODO: handle the other cases
     }
-    // TODO: handle the other cases
   }
 
   void Check(const parser::ForallStmt &stmt) {

diff --git a/flang/module/__fortran_ieee_exceptions.f90 b/flang/module/__fortran_ieee_exceptions.f90
index 895eee5..77dc6f8 100644 (file)
--- a/flang/module/__fortran_ieee_exceptions.f90
+++ b/flang/module/__fortran_ieee_exceptions.f90
@@ -80,14 +80,14 @@ module __Fortran_ieee_exceptions
   end interface
 
   interface ieee_get_modes
-    subroutine ieee_get_modes_0(modes)
+    pure subroutine ieee_get_modes_0(modes)
       import ieee_modes_type
       type(ieee_modes_type), intent(out) :: modes
     end subroutine ieee_get_modes_0
   end interface
 
   interface ieee_get_status
-    subroutine ieee_get_status_0(status)
+    pure subroutine ieee_get_status_0(status)
       import ieee_status_type
       type(ieee_status_type), intent(out) :: status
     end subroutine ieee_get_status_0

diff --git a/flang/test/Semantics/call11.f90 b/flang/test/Semantics/call11.f90
index 4307571..f4f4740 100644 (file)
--- a/flang/test/Semantics/call11.f90
+++ b/flang/test/Semantics/call11.f90
@@ -39,7 +39,7 @@ module m
     end forall
     !ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
     do concurrent (j=1:1, impure(j) /= 0) ! C1121
-      !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
       a(j) = impure(j) ! C1139
     end do
   end subroutine
@@ -61,7 +61,7 @@ module m
     end do
     !ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
     do concurrent (j=1:1, x%tbp_impure(j) /= 0) ! C1121
-      !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
       a(j) = x%tbp_impure(j) ! C1139
     end do
   end subroutine

diff --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90
index 36595df..7c13a26 100644 (file)
--- a/flang/test/Semantics/doconcurrent01.f90
+++ b/flang/test/Semantics/doconcurrent01.f90
@@ -48,8 +48,7 @@ subroutine do_concurrent_test2(i,j,n,flag)
     change team (j)
 !ERROR: An image control statement is not allowed in DO CONCURRENT
       critical
-!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
-        call ieee_get_status(status)
+        call ieee_get_status(status) ! ok
 !ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
         call ieee_set_halting_mode(flag, halting)
       end critical
@@ -193,6 +192,10 @@ subroutine s7()
     pure integer function pf()
     end function pf
   end interface
+  interface generic
+    impure integer function ipf()
+    end function ipf
+  end interface
 
   type :: procTypeNotPure
     procedure(notPureFunc), pointer, nopass :: notPureProcComponent
@@ -223,10 +226,16 @@ subroutine s7()
 
   ! This should generate an error
   do concurrent (i = 1:10)
-!ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+!ERROR: Impure procedure 'notpureproccomponent' may not be referenced in DO CONCURRENT
     ivar = procVarNotPure%notPureProcComponent()
   end do
 
+  ! This should generate an error
+  do concurrent (i = 1:10)
+!ERROR: Impure procedure 'ipf' may not be referenced in DO CONCURRENT
+    ivar = generic()
+  end do
+
   contains
     integer function notPureFunc()
       notPureFunc = 2

diff --git a/flang/test/Semantics/doconcurrent09.f90 b/flang/test/Semantics/doconcurrent09.f90
index d783da0..2e7a79c 100644 (file)
--- a/flang/test/Semantics/doconcurrent09.f90
+++ b/flang/test/Semantics/doconcurrent09.f90
@@ -33,15 +33,15 @@ program test
   do concurrent (j=1:1)
     call ps(1) ! ok
     call purity(1) ! ok
-    !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+    !ERROR: Impure procedure 'ips' may not be referenced in DO CONCURRENT
     call purity(1.)
-    !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+    !ERROR: Impure procedure 'ips' may not be referenced in DO CONCURRENT
     call ips(1.)
     call x%pb(1) ! ok
     call x%purity(1) ! ok
-    !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+    !ERROR: Impure procedure 'ipb' may not be referenced in DO CONCURRENT
     call x%purity(1.)
-    !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+    !ERROR: Impure procedure 'ipb' may not be referenced in DO CONCURRENT
     call x%ipb(1.)
   end do
 end program