[flang] Catch impure specifics called in DO CONCURRENT

[klausler]

Summary

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.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Evaluate/intrinsics.cpp

for (std::size_t j{0}; j < dummies; ++j) {
     }
     dummyArgs.back().SetIntent(d.intent);
   }
   characteristics::Procedure::Attrs attrs;
   if (elementalRank > 0) {
     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}},
         std::move(rearranged)};
   } else {
     attrs.set(characteristics::Procedure::Attr::Pure);
     characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
     characteristics::FunctionResult funcResult{std::move(typeAndShape)};

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

 //===-- lib/Semantics/check-do-forall.cpp ---------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "check-do-forall.h"
 #include "definable.h"
 #include "flang/Common/template.h"
 #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"
 #include "flang/Semantics/attr.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"

 // 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body
 class DoConcurrentBodyEnforce {
 public:
   DoConcurrentBodyEnforce(
       SemanticsContext &context, parser::CharBlock doConcurrentSourcePosition)
       : 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()) {
       labels_.insert(*statement.label);
     }
     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
   // entity, assignment to an allocatable variable, or an actual DEALLOCATE
   // statement
   //
   // Note also that the deallocation of a derived type entity might cause the
   // invocation of an IMPURE final subroutine. (C1139)
public:
   }
 
   // C1139: call to impure procedure and ...
   // C1141: cannot call ieee_get_flag, ieee_[gs]et_halting_mode
   // It's not necessary to check the ieee_get* procedures because they're
   // 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") {
           SayWithDo(context_, currentStatementSourcePosition_,
               "IEEE_SET_HALTING_MODE is not allowed in DO "
               "CONCURRENT"_err_en_US,
               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_);
-      }
     }
   }
 
   // 11.1.7.5, paragraph 5, no ADVANCE specifier in a DO CONCURRENT
   void Post(const parser::IoControlSpec &ioControlSpec) {
     if (auto *charExpr{
             std::get_if<parser::IoControlSpec::CharExpr>(&ioControlSpec.u)}) {
       if (std::get<parser::IoControlSpec::CharExpr::Kind>(charExpr->t) ==
void DeactivateIndexVars(
     for (const auto &control : controls) {
       context_.DeactivateIndexVar(std::get<parser::Name>(control.t));
     }
   }
 
   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
     }
+  }
 
   void Check(const parser::ForallStmt &stmt) {
     CheckConcurrentHeader(GetConcurrentHeader(stmt));
   }
   void Check(const parser::ForallConstruct &construct) {
     CheckConcurrentHeader(GetConcurrentHeader(construct));
   }
 

flang/module/__fortran_ieee_exceptions.f90

interface ieee_get_halting_mode
     elemental subroutine ieee_get_halting_mode_0(flag, halting)
       import ieee_flag_type
       type(ieee_flag_type), intent(in) :: flag
       logical, intent(out) :: halting
     end subroutine ieee_get_halting_mode_0
   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
   end interface
 
 #define IEEE_SET_FLAG_L(FVKIND) \
   pure subroutine ieee_set_flag_l##FVKIND(flag,flag_value); \
     import ieee_flag_type; \

flang/test/Semantics/call11.f90

forall (j=1:1)
       a(j) = impure(j) ! C1037
     end forall
     forall (j=1:1)
       !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
       a(j) = pure(impure(j)) ! C1037
     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
 
   subroutine test2
     type(t) :: x
     real :: a(x%tbp_pure(1)) ! ok
     !ERROR: Invalid specification expression: reference to impure function 'impure'
     real :: b(x%tbp_impure(1))
     forall (j=1:1)
       a(j) = x%tbp_pure(j) ! ok
     end forall
     forall (j=1:1)
       !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
       a(j) = x%tbp_impure(j) ! C1037
     end forall
     do concurrent (j=1:1, x%tbp_pure(j) /= 0) ! ok
       a(j) = x%tbp_pure(j) ! ok
     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
 
   subroutine test3
     type :: t
       integer :: i
     end type

flang/test/Semantics/doconcurrent01.f90

subroutine do_concurrent_test2(i,j,n,flag)
   type(ieee_status_type) :: status
   do concurrent (i = 1:n)
 !ERROR: An image control statement is not allowed in DO CONCURRENT
     sync team (j)
 !ERROR: An image control statement is not allowed in DO CONCURRENT
     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
     end team
 !ERROR: ADVANCE specifier is not allowed in DO CONCURRENT
     write(*,'(a35)',advance='no')
   end do
 
!ERROR: An image control statement is not allowed in DO CONCURRENT
   end do
 end subroutine s6
 
 subroutine s7()
   interface
     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
   end type procTypeNotPure
 
   type :: procTypePure
     procedure(pf), pointer, nopass :: pureProcComponent
   end type procTypePure
subroutine s7()
 
   ! This should not generate errors
   do concurrent (i = 1:10)
     ivar = procVarPure%pureProcComponent()
   end do
 
   ! 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
     end function notPureFunc
 
     pure integer function pureFunc()
       pureFunc = 3
     end function pureFunc

flang/test/Semantics/doconcurrent09.f90

 end module
 
 program test
   use m
   type(t) :: x
   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