[flang] Fix purity testing for generic calls

[klausler]

Summary

The purity or impurity of a call to a generic interface
depends on the attributes of the specific procedure or specific
binding. Change expression analysis of calls to generic interfaces
to replace the symbol in the parse tree with the specific procedure
or binding; this ensures that later checking for purity in
DO CONCURRENT and other contexts will be accurate.

Remove an "XFAIL" from a test that now passes again with this fix.

[vdonaldson]

Thanks for this fix. The test "XFAIL" mention in the summary / commit message doesn't apply to this instance of the fix, if it is easy to correct that.

flang/lib/Semantics/expression.cpp

if (const Symbol * sym{sc.component.symbol}) {
               [&](const Symbol &proc, ActualArguments &actuals) {
                 if (!proc.attrs().test(semantics::Attr::NOPASS)) {
                   AddPassArg(actuals, std::move(*dtExpr), proc);
                 }
                 return true;
               }};
           auto pair{ResolveGeneric(*sym, arguments, adjustment)};
           sym = pair.first;
-          if (!sym) {
+          if (sym) {
+            // re-resolve the name to the specific binding
+            sc.component.symbol = const_cast<Symbol *>(sym);
+          } else {
             EmitGenericResolutionError(*sc.component.symbol, pair.second);
             return std::nullopt;
           }
         }
         if (const Symbol *
             resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
           AddPassArg(arguments, std::move(*dtExpr), *sym, false);
           return CalleeAndArguments{
auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
   bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};
   const Symbol *resolution{nullptr};
   if (isGenericInterface) {
     ExpressionAnalyzer::AdjustActuals noAdjustment;
     auto pair{ResolveGeneric(
         *symbol, arguments, noAdjustment, mightBeStructureConstructor)};
     resolution = pair.first;
     dueToNullActual = pair.second;
+    if (resolution) {
+      // re-resolve name to the specific procedure
+      name.symbol = const_cast<Symbol *>(resolution);
+    }
   }
   if (!resolution) {
     // Not generic, or no resolution; may be intrinsic
     bool isIntrinsic{symbol->attrs().test(semantics::Attr::INTRINSIC)};
     if (!isIntrinsic && !isGenericInterface) {
       resolution = symbol;
     } else if (std::optional<SpecificCall> specificCall{
                    context_.intrinsics().Probe(

flang/test/Semantics/doconcurrent09.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Ensure that DO CONCURRENT purity checks apply to specific procedures
+! in the case of calls to generic interfaces.
+module m
+  interface purity
+    module procedure :: ps, ips
+  end interface
+  type t
+   contains
+    procedure :: pb, ipb
+    generic :: purity => pb, ipb
+  end type
+ contains
+  pure subroutine ps(n)
+    integer, intent(in) :: n
+  end subroutine
+  impure subroutine ips(a)
+    real, intent(in) :: a
+  end subroutine
+  pure subroutine pb(x,n)
+    class(t), intent(in) :: x
+    integer, intent(in) :: n
+  end subroutine
+  impure subroutine ipb(x,n)
+    class(t), intent(in) :: x
+    real, intent(in) :: n
+  end subroutine
+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
+    call purity(1.)
+    !ERROR: Call to an impure procedure is not allowed 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
+    call x%purity(1.)
+    !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+    call x%ipb(1.)
+  end do
+end program