[flang] Changes to check for calls to PURE procedure components

This addresses issue flang-compiler/f18#781.  I changed my test to create a PURE procedure
component by using an interface as suggested by Peter and Jean.  I then
enhanced the function IsPureProcedure() in tools.cc to cover this case
and updated the code in check-do.cc to perform the test.

Original-commit: flang-compiler/f18@5df56a217d
Reviewed-on: https://github.com/flang-compiler/f18/pull/789

flang/lib/semantics/check-do.cc

@@ -167,7 +167,7 @@ public:
         }
       }
     } else {
-      // C1139: check for an impure procedure component
+      // C1139: this a procedure component
       auto &component{std::get<parser::ProcComponentRef>(procedureDesignator.u)
                           .v.thing.component};
       if (component.symbol && !IsPureProcedure(*component.symbol)) {

flang/lib/semantics/tools.cc

@@ -167,6 +167,12 @@ bool IsFunction(const Symbol &symbol) {
 }
 
 bool IsPureProcedure(const Symbol &symbol) {
+  if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
+    if (const Symbol *procInterface{procDetails->interface().symbol()}) {
+      // procedure component with a PURE interface
+      return IsPureProcedure(*procInterface);
+    }
+  }
   return symbol.attrs().test(Attr::PURE) && IsProcedure(symbol);
 }
 

flang/test/semantics/doconcurrent01.f90

@@ -204,3 +204,53 @@ call move_alloc(ca, cb)
     call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
   end do
 end subroutine s6
+
+subroutine s7()
+  interface
+    pure integer function pf()
+    end function pf
+  end interface
+
+  type :: procTypeNotPure
+    procedure(notPureFunc), pointer, nopass :: notPureProcComponent
+  end type procTypeNotPure
+
+  type :: procTypePure
+    procedure(pf), pointer, nopass :: pureProcComponent
+  end type procTypePure
+
+  type(procTypeNotPure) :: procVarNotPure
+  type(procTypePure) :: procVarPure
+  integer :: ivar
+
+  procVarPure%pureProcComponent => pureFunc
+
+  do concurrent (i = 1:10)
+    print *, "hello"
+  end do
+
+  do concurrent (i = 1:10)
+    ivar = pureFunc()
+  end do
+
+  ! 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
+    ivar = procVarNotPure%notPureProcComponent()
+  end do
+
+  contains
+    integer function notPureFunc()
+      notPureFunc = 2
+    end function notPureFunc
+
+    pure integer function pureFunc()
+      pureFunc = 3
+    end function pureFunc
+
+end subroutine s7