From 203627d3a5b45c95a2e845e242c97f6baf11bd7f Mon Sep 17 00:00:00 2001
From: Tim Keith <tkeith@nvidia.com>
Date: Tue, 3 Dec 2019 08:43:05 -0800
Subject: [PATCH] [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
---
 flang/lib/evaluate/check-expression.cc |  2 +-
 flang/lib/semantics/tools.cc           |  6 +++++-
 flang/test/semantics/call11.f90        | 26 ++++++++++++++++++++++++--
 3 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/flang/lib/evaluate/check-expression.cc b/flang/lib/evaluate/check-expression.cc
index d48337ba4ad7..60fedce85efa 100644
--- 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 263e70d6c6b6..25c7e11aedbc 100644
--- 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 f2efbf6d2041..50ee8aa4ff27 100644
--- 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