[flang] Fix PURE check on procedure binding

A symbol that represents a procedure binding is PURE if the procedure
it is bound to is PURE. Fix `IsPureProcedure` to check that.

Make use of `IsPureProcedure` in `CheckSpecificationExprHelper`.

Original-commit: flang-compiler/f18@c95f2eb4fb25d464977690ba03260be2451911d7
Reviewed-on: https://github.com/flang-compiler/f18/pull/849

diff --git a/flang/lib/evaluate/check-expression.cc b/flang/lib/evaluate/check-expression.cc
index d48337b..60fedce 100644 (file)
--- a/flang/lib/evaluate/check-expression.cc
+++ b/flang/lib/evaluate/check-expression.cc
@@ -218,7 +218,7 @@ public:
 
   template<typename T> Result operator()(const FunctionRef<T> &x) const {
     if (const auto *symbol{x.proc().GetSymbol()}) {
-      if (!symbol->attrs().test(semantics::Attr::PURE)) {
+      if (!semantics::IsPureProcedure(*symbol)) {
         return "reference to impure function '"s + symbol->name().ToString() +
             "'";
       }

diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc
index 263e70d..25c7e11 100644 (file)
--- a/flang/lib/semantics/tools.cc
+++ b/flang/lib/semantics/tools.cc
@@ -242,8 +242,12 @@ bool IsPureProcedure(const Symbol &symbol) {
       // procedure component with a PURE interface
       return IsPureProcedure(*procInterface);
     }
+  } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
+    return IsPureProcedure(details->symbol());
+  } else if (!IsProcedure(symbol)) {
+    return false;
   }
-  return symbol.attrs().test(Attr::PURE) && IsProcedure(symbol);
+  return symbol.attrs().test(Attr::PURE);
 }
 
 bool IsPureProcedure(const Scope &scope) {

diff --git a/flang/test/semantics/call11.f90 b/flang/test/semantics/call11.f90
index f2efbf6..50ee8aa 100644 (file)
--- a/flang/test/semantics/call11.f90
+++ b/flang/test/semantics/call11.f90
@@ -18,12 +18,13 @@ module m
 
   type :: t
    contains
-    procedure, nopass :: tbp => pure
+    procedure, nopass :: tbp_pure => pure
+    procedure, nopass :: tbp_impure => impure
   end type
   type, extends(t) :: t2
    contains
     !ERROR: An overridden PURE type-bound procedure binding must also be PURE
-    procedure, nopass :: tbp => impure ! 7.5.7.3
+    procedure, nopass :: tbp_pure => impure ! 7.5.7.3
   end type
 
  contains
@@ -51,4 +52,25 @@ module m
       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 'tbp_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 'tbp_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: Concurrent-header mask expression cannot reference an impure procedure
+    do concurrent (j=1:1, x%tbp_impure(j) /= 0) ! C1121
+      !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+      a(j) = x%tbp_impure(j) ! C1139
+    end do
+  end subroutine
 end module