[flang] Resolve calls to type-bound generic names

Extend `ResolveGeneric` to handle calls to procedure components by
passing in the data-ref that is used as the passed-object argument.

`AddPassArg` takes care of adding a placeholder for the passed object.
This is shared by the generic and non-generic cases of calls to
procedure components.

Original-commit: flang-compiler/f18@be83590
Reviewed-on: flang-compiler/f18#863

flang/lib/semantics/check-call.cc

@@ -572,7 +572,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
                     "Assumed-type TYPE(*) '%s' may be associated only with an assumed-TYPE(*) %s"_err_en_US,
                     assumed->name(), dummyName);
               }
-            } else {
+            } else if (!arg.IsPassedObject()) {
               messages.Say(
                   "Actual argument is not an expression or variable"_err_en_US);
             }

flang/lib/semantics/expression.cc

@@ -1553,13 +1553,41 @@ static int GetPassIndex(const semantics::Symbol &proc, parser::CharBlock name) {
   return 0;  // first argument is passed-object
 }
 
+// Given a call `base%component(actuals)`, create a copy of actuals that
+// includes a place-holder for the passed-object argument, if any.
+// Return the index of that argument, or nullopt if there isn't one.
+static std::optional<int> AddPassArg(
+    const Symbol &component, ActualArguments &actuals) {
+  if (component.attrs().test(semantics::Attr::NOPASS)) {
+    return std::nullopt;
+  }
+  std::optional<parser::CharBlock> passName{GetPassName(component)};
+  int passIndex{passName ? GetPassIndex(component, *passName) : 0};
+  auto iter{actuals.begin()};
+  int at{0};
+  while (iter < actuals.end() && at < passIndex) {
+    if (*iter && (*iter)->keyword()) {
+      iter = actuals.end();
+      break;
+    }
+    ++iter;
+    ++at;
+  }
+  ActualArgument passed{ActualArgument::PassedObject{}};
+  if (iter == actuals.end() && passName) {
+    passed.set_keyword(*passName);
+  }
+  actuals.emplace(iter, std::move(passed));
+  return passIndex;
+}
+
 auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
     const parser::ProcComponentRef &pcr, ActualArguments &&arguments)
     -> std::optional<CalleeAndArguments> {
   const parser::StructureComponent &sc{pcr.v.thing};
   const auto &name{sc.component.source};
   if (MaybeExpr base{Analyze(sc.base)}) {
-    if (Symbol * sym{sc.component.symbol}) {
+    if (const Symbol * sym{sc.component.symbol}) {
       if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
         const semantics::DerivedTypeSpec *dtSpec{nullptr};
         const auto *binding{sym->detailsIf<semantics::ProcBindingDetails>()};
@@ -1576,34 +1604,20 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
           }
         }
         if (dtSpec && dtSpec->scope()) {
+          if (sym->has<semantics::GenericDetails>()) {
+            sym = ResolveGeneric(*sym, arguments, *dtExpr);
+            if (!sym) {
+              return std::nullopt;
+            }
+          }
           if (std::optional<DataRef> dataRef{
                   ExtractDataRef(std::move(*dtExpr))}) {
-            if (auto component{CreateComponent(
+            if (std::optional<Component> component{CreateComponent(
                     std::move(*dataRef), *sym, *dtSpec->scope())}) {
-              if (!sym->attrs().test(semantics::Attr::NOPASS)) {
-                // There's a PASS argument by which the base of the procedure
-                // component reference must be passed.  Append or insert it to
-                // the list of actual arguments.
-                auto passName{GetPassName(*sym)};
-                int passIndex{passName ? GetPassIndex(*sym, *passName) : 0};
-                auto iter{arguments.begin()};
-                int at{0};
-                while (iter < arguments.end() && at < passIndex) {
-                  if (*iter && (*iter)->keyword()) {
-                    iter = arguments.end();
-                    break;
-                  }
-                  ++iter;
-                  ++at;
-                }
-                ActualArgument passed{ActualArgument::PassedObject{}};
+              if (std::optional<int> passIndex{AddPassArg(*sym, arguments)}) {
                 if (resolution) {
-                  passed = ActualArgument{AsGenericExpr(std::move(*dtExpr))};
+                  arguments[*passIndex] = AsGenericExpr(std::move(*dtExpr));
                 }
-                if (iter == arguments.end() && passName) {
-                  passed.set_keyword(*passName);
-                }
-                arguments.emplace(iter, std::move(passed));
               }
               return CalleeAndArguments{resolution
                       ? ProcedureDesignator{*resolution}
@@ -1672,15 +1686,23 @@ static bool CheckCompatibleArguments(
   return true;
 }
 
-const Symbol *ExpressionAnalyzer::ResolveGeneric(
-    const Symbol &symbol, ActualArguments &actuals) {
+// Resolve a call to a generic procedure with given actual arguments.
+// If it's a procedure component, base is the data-ref to the left of the '%'.
+const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
+    const ActualArguments &actuals,
+    const std::optional<Expr<SomeDerived>> &base) {
   const Symbol *elemental{nullptr};  // matching elemental specific proc
   const auto &details{symbol.GetUltimate().get<semantics::GenericDetails>()};
   for (const Symbol &specific : details.specificProcs()) {
     if (std::optional<characteristics::Procedure> procedure{
             characteristics::Procedure::Characterize(
                 ProcedureDesignator{specific}, context_.intrinsics())}) {
       ActualArguments localActuals{actuals};
+      if (specific.has<semantics::ProcBindingDetails>()) {
+        if (std::optional<int> passIndex{AddPassArg(specific, localActuals)}) {
+          localActuals[*passIndex] = AsGenericExpr(common::Clone(base.value()));
+        }
+      }
       if (semantics::CheckInterfaceForGeneric(
               *procedure, localActuals, GetFoldingContext())) {
         if (CheckCompatibleArguments(*procedure, localActuals)) {
@@ -1807,7 +1829,6 @@ MaybeExpr ExpressionAnalyzer::AnalyzeCall(
     analyzer.Analyze(arg, isSubroutine);
   }
   if (!analyzer.fatalErrors()) {
-    // TODO: map non-intrinsic generic procedure to specific procedure
     if (std::optional<CalleeAndArguments> callee{
             GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
                 analyzer.GetActuals(), isSubroutine)}) {

flang/lib/semantics/expression.h

@@ -328,7 +328,8 @@ class ExpressionAnalyzer {
       const parser::Call &, bool isSubroutine);
   std::optional<characteristics::Procedure> CheckCall(
       parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
-  const Symbol *ResolveGeneric(const Symbol &, ActualArguments &);
+  const Symbol *ResolveGeneric(const Symbol &, const ActualArguments &,
+      const std::optional<Expr<SomeDerived>> & = std::nullopt);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::Name &, ActualArguments &&, bool isSubroutine = false);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(

flang/test/semantics/CMakeLists.txt

@@ -104,6 +104,7 @@ set(ERROR_TESTS
   resolve65.f90
   resolve66.f90
   resolve67.f90
+  resolve68.f90
   stop01.f90
   structconst01.f90
   structconst02.f90
@@ -262,6 +263,7 @@ set(MODFILE_TESTS
   modfile31.f90
   modfile32.f90
   modfile33.f90
+  modfile34.f90
 )
 
 set(LABEL_TESTS

flang/test/semantics/modfile34.f90

@@ -0,0 +1,94 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Test resolution of type-bound generics.
+
+module m1
+  type :: t
+  contains
+    procedure, pass(x) :: add1 => add
+    procedure, nopass :: add2 => add
+    procedure :: add_real
+    generic :: g => add1, add2, add_real
+  end type
+contains
+  integer(8) pure function add(x, y)
+    class(t), intent(in) :: x, y
+  end
+  integer(8) pure function add_real(x, y)
+    class(t), intent(in) :: x
+    real, intent(in) :: y
+  end
+  subroutine test1(x, y, z)
+    type(t) :: x, y
+    real :: z(x%add1(y))
+  end
+  subroutine test2(x, y, z)
+    type(t) :: x, y
+    real :: z(x%g(y))
+  end
+  subroutine test3(x, y, z)
+    type(t) :: x, y
+    real :: z(x%g(y, x))
+  end
+  subroutine test4(x, y, z)
+    type(t) :: x
+    real :: y
+    real :: z(x%g(y))
+  end
+end
+
+!Expect: m1.mod
+!module m1
+! type :: t
+! contains
+!  procedure, pass(x) :: add1 => add
+!  procedure, nopass :: add2 => add
+!  procedure :: add_real
+!  generic :: g => add1
+!  generic :: g => add2
+!  generic :: g => add_real
+! end type
+!contains
+! pure function add(x, y)
+!  class(t), intent(in) :: x
+!  class(t), intent(in) :: y
+!  integer(8) :: add
+! end
+! pure function add_real(x, y)
+!  class(t), intent(in) :: x
+!  real(4), intent(in) :: y
+!  integer(8) :: add_real
+! end
+! subroutine test1(x, y, z)
+!  type(t) :: x
+!  type(t) :: y
+!  real(4) :: z(1_8:add(x, y))
+! end
+! subroutine test2(x, y, z)
+!  type(t) :: x
+!  type(t) :: y
+!  real(4) :: z(1_8:x%add1(y))
+! end
+! subroutine test3(x, y, z)
+!  type(t) :: x
+!  type(t) :: y
+!  real(4) :: z(1_8:x%add2(y, x))
+! end
+! subroutine test4(x, y, z)
+!  type(t) :: x
+!  real(4) :: y
+!  real(4) :: z(1_8:x%add_real(y))
+! end
+!end

flang/test/semantics/resolve68.f90

@@ -0,0 +1,47 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Test resolution of type-bound generics.
+
+module m1
+  type :: t
+  contains
+    procedure, pass(x) :: add1 => add
+    procedure, nopass :: add2 => add
+    procedure :: add_real
+    generic :: g => add1, add2, add_real
+  end type
+contains
+  integer function add(x, y)
+    class(t), intent(in) :: x, y
+  end
+  integer function add_real(x, y)
+    class(t), intent(in) :: x
+    real, intent(in) :: y
+  end
+  subroutine test1(x, y, z)
+    type(t) :: x
+    integer :: y
+    integer :: z
+    !ERROR: No specific procedure of generic 'g' matches the actual arguments
+    z = x%g(y)
+  end
+  subroutine test2(x, y, z)
+    type(t) :: x
+    real :: y
+    integer :: z
+    !ERROR: No specific procedure of generic 'g' matches the actual arguments
+    z = x%g(x, y)
+  end
+end