Merge pull request #778 from flang-compiler/tsk-generics

Generic name resolution in expression analysis

lib/evaluate/check-call.cc

@@ -72,7 +72,7 @@ static void CheckImplicitInterfaceArg(
   }
 }
 
-static void CheckExplicitInterfaceArg(const ActualArgument &arg,
+static bool CheckExplicitInterfaceArg(const ActualArgument &arg,
     const characteristics::DummyArgument &dummy, FoldingContext &context) {
   std::visit(
       common::visitors{
@@ -95,9 +95,10 @@ static void CheckExplicitInterfaceArg(const ActualArgument &arg,
           },
       },
       dummy.u);
+  return true;  // TODO: return false when error detected
 }
 
-static void RearrangeArguments(const characteristics::Procedure &proc,
+static bool RearrangeArguments(const characteristics::Procedure &proc,
     ActualArguments &actuals, parser::ContextualMessages &messages) {
   CHECK(proc.HasExplicitInterface());
   if (actuals.size() < proc.dummyArguments.size()) {
@@ -106,6 +107,7 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
     messages.Say(
         "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
         actuals.size(), proc.dummyArguments.size());
+    return false;
   }
   std::map<std::string, ActualArgument> kwArgs;
   for (auto &x : actuals) {
@@ -117,6 +119,7 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
           messages.Say(*x->keyword,
               "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
               *x->keyword);
+          return false;
         }
         x.reset();
       }
@@ -133,6 +136,7 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
             messages.Say(*x.keyword,
                 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
                 *x.keyword, index + 1);
+            return false;
           } else {
             actuals[index] = std::move(x);
           }
@@ -146,42 +150,55 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
       messages.Say(*x.keyword,
           "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
           *x.keyword);
+      return false;
     }
   }
+  return true;
+}
+
+bool CheckExplicitInterface(const characteristics::Procedure &proc,
+    ActualArguments &actuals, FoldingContext &context) {
+  if (!RearrangeArguments(proc, actuals, context.messages())) {
+    return false;
+  }
+  int index{0};
+  for (auto &actual : actuals) {
+    const auto &dummy{proc.dummyArguments[index++]};
+    if (actual.has_value()) {
+      if (!CheckExplicitInterfaceArg(*actual, dummy, context)) {
+        return false;
+      }
+    } else if (!dummy.IsOptional()) {
+      if (dummy.name.empty()) {
+        context.messages().Say(
+            "Dummy argument #%d is not OPTIONAL and is not associated with an "
+            "effective argument in this procedure reference"_err_en_US,
+            index);
+      } else {
+        context.messages().Say(
+            "Dummy argument '%s' (#%d) is not OPTIONAL and is not associated "
+            "with an effective argument in this procedure reference"_err_en_US,
+            dummy.name, index);
+      }
+      return false;
+    }
+  }
+  return true;
 }
 
 void CheckArguments(const characteristics::Procedure &proc,
     ActualArguments &actuals, FoldingContext &context,
     bool treatingExternalAsImplicit) {
   parser::Messages buffer;
   parser::ContextualMessages messages{context.messages().at(), &buffer};
-  FoldingContext localContext{context, messages};
   if (proc.HasExplicitInterface()) {
-    RearrangeArguments(proc, actuals, messages);
-    int index{0};
-    for (auto &x : actuals) {
-      const auto &dummy{proc.dummyArguments[index++]};
-      if (x.has_value()) {
-        CheckExplicitInterfaceArg(*x, dummy, localContext);
-      } else if (!dummy.IsOptional()) {
-        if (dummy.name.empty()) {
-          messages.Say(
-              "Dummy argument #%d is not OPTIONAL and is not associated with an effective argument in this procedure reference"_err_en_US,
-              index);
-        } else {
-          messages.Say(
-              "Dummy argument '%s' (#%d) is not OPTIONAL and is not associated with an effective argument in this procedure reference"_err_en_US,
-              dummy.name, index);
-        }
-      }
-      if (treatingExternalAsImplicit) {
-        CheckImplicitInterfaceArg(*x, context.messages());
-      }
-    }
-  } else {
-    for (auto &x : actuals) {
-      if (x.has_value()) {
-        CheckImplicitInterfaceArg(*x, context.messages());
+    FoldingContext localContext{context, messages};
+    CheckExplicitInterface(proc, actuals, localContext);
+  }
+  if (!proc.HasExplicitInterface() || treatingExternalAsImplicit) {
+    for (auto &actual : actuals) {
+      if (actual.has_value()) {
+        CheckImplicitInterfaceArg(*actual, messages);
       }
     }
   }

lib/evaluate/check-call.h

@@ -35,5 +35,11 @@ class FoldingContext;
 // defined at the top level in the same source file.
 void CheckArguments(const characteristics::Procedure &, ActualArguments &,
     FoldingContext &, bool treatingExternalAsImplicit = false);
+
+// Check actual arguments against a procedure with an explicit interface.
+// Report an error and return false if not compatible.
+bool CheckExplicitInterface(
+    const characteristics::Procedure &, ActualArguments &, FoldingContext &);
+
 }
 #endif

lib/semantics/expression.cc

@@ -1514,17 +1514,92 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
   return std::nullopt;
 }
 
+// Can actual be argument associated with dummy?
+static bool CheckCompatibleArgument(bool isElemental,
+    const ActualArgument &actual, const characteristics::DummyArgument &dummy) {
+  return std::visit(
+      common::visitors{
+          [&](const characteristics::DummyDataObject &x) {
+            characteristics::TypeAndShape dummyTypeAndShape{x.type};
+            if (!isElemental && actual.Rank() != dummyTypeAndShape.Rank()) {
+              return false;
+            } else if (auto actualType{actual.GetType()}) {
+              return dummyTypeAndShape.type().IsTkCompatibleWith(*actualType);
+            } else {
+              return false;
+            }
+          },
+          [&](const characteristics::DummyProcedure &) {
+            const auto *expr{actual.UnwrapExpr()};
+            return expr && IsProcedurePointer(*expr);
+          },
+          [&](const characteristics::AlternateReturn &) {
+            return actual.isAlternateReturn;
+          },
+      },
+      dummy.u);
+}
+
+// Are the actual arguments compatible with the dummy arguments of procedure?
+static bool CheckCompatibleArguments(
+    const characteristics::Procedure &procedure,
+    const ActualArguments &actuals) {
+  bool isElemental{procedure.IsElemental()};
+  const auto &dummies{procedure.dummyArguments};
+  CHECK(dummies.size() == actuals.size());
+  for (std::size_t i{0}; i < dummies.size(); ++i) {
+    const characteristics::DummyArgument &dummy{dummies[i]};
+    const std::optional<ActualArgument> &actual{actuals[i]};
+    if (actual && !CheckCompatibleArgument(isElemental, *actual, dummy)) {
+      return false;
+    }
+  }
+  return true;
+}
+
+const Symbol *ExpressionAnalyzer::ResolveGeneric(
+    const Symbol &symbol, ActualArguments &actuals) {
+  const Symbol *elemental{nullptr};  // matching elemental specific proc
+  const auto &details{symbol.get<semantics::GenericDetails>()};
+  for (const Symbol *specific : details.specificProcs()) {
+    if (std::optional<characteristics::Procedure> procedure{
+            characteristics::Procedure::Characterize(
+                ProcedureDesignator{*specific}, context_.intrinsics())}) {
+      parser::Messages buffer;
+      parser::ContextualMessages messages{
+          context_.foldingContext().messages().at(), &buffer};
+      FoldingContext localContext{context_.foldingContext(), messages};
+      ActualArguments localActuals{actuals};
+      if (CheckExplicitInterface(*procedure, localActuals, localContext) &&
+          CheckCompatibleArguments(*procedure, localActuals)) {
+        if (!procedure->IsElemental()) {
+          return specific;  // takes priority over elemental match
+        }
+        elemental = specific;
+      }
+    }
+  }
+  if (elemental) {
+    return elemental;
+  } else {
+    Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
+        symbol.name());
+    return nullptr;
+  }
+}
+
 auto ExpressionAnalyzer::GetCalleeAndArguments(
     const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
     bool isSubroutine) -> std::optional<CalleeAndArguments> {
   return std::visit(
       common::visitors{
           [&](const parser::Name &n) -> std::optional<CalleeAndArguments> {
-            if (context_.HasError(n.symbol)) {
+            const Symbol *symbol{n.symbol};
+            if (context_.HasError(symbol)) {
               return std::nullopt;
             }
-            const Symbol &symbol{n.symbol->GetUltimate()};
-            if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
+            const Symbol &ultimate{symbol->GetUltimate()};
+            if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
               if (std::optional<SpecificCall> specificCall{
                       context_.intrinsics().Probe(
                           CallCharacteristics{n.source, isSubroutine},
@@ -1536,12 +1611,18 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(
                 return std::nullopt;
               }
             }
-            CheckForBadRecursion(n.source, symbol);
-            return CalleeAndArguments{
-                ProcedureDesignator{*n.symbol}, std::move(arguments)};
+            CheckForBadRecursion(n.source, ultimate);
+            if (ultimate.has<semantics::GenericDetails>()) {
+              symbol = ResolveGeneric(ultimate, arguments);
+            }
+            if (symbol) {
+              return CalleeAndArguments{
+                  ProcedureDesignator{*symbol}, std::move(arguments)};
+            } else {
+              return std::nullopt;
+            }
           },
-          [&](const parser::ProcComponentRef &pcr)
-              -> std::optional<CalleeAndArguments> {
+          [&](const parser::ProcComponentRef &pcr) {
             return AnalyzeProcedureComponentRef(pcr, std::move(arguments));
           },
       },
@@ -1699,10 +1780,9 @@ std::optional<ActualArguments> ExpressionAnalyzer::AnalyzeArguments(
 static bool IsExternalCalledImplicitly(
     parser::CharBlock callSite, const ProcedureDesignator &proc) {
   if (const auto *symbol{proc.GetSymbol()}) {
-    return !callSite.empty() && symbol->has<semantics::SubprogramDetails>() &&
-        (symbol->owner().IsGlobal() ||
-            (symbol->owner().parent().IsGlobal() &&
-                !symbol->owner().sourceRange().Contains(callSite)));
+    return symbol->has<semantics::SubprogramDetails>() &&
+        symbol->owner().IsGlobal() &&
+        !symbol->scope()->sourceRange().Contains(callSite);
   } else {
     return false;
   }

lib/semantics/expression.h

@@ -326,7 +326,7 @@ class ExpressionAnalyzer {
       const parser::Call &, bool isSubroutine);
   std::optional<characteristics::Procedure> CheckCall(
       parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
-
+  const Symbol *ResolveGeneric(const Symbol &, ActualArguments &);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::ProcedureDesignator &, ActualArguments &&,
       bool isSubroutine);

lib/semantics/resolve-names.cc

@@ -609,7 +609,7 @@ class InterfaceVisitor : public virtual ScopeHandler {
   GenericDetails &GetGenericDetails();
   // Add to generic the symbol for the subprogram with the same name
   void CheckGenericProcedures(Symbol &);
-  void CheckSpecificsAreDistinguishable(const Symbol &, const SymbolVector &);
+  void CheckSpecificsAreDistinguishable(Symbol &, const SymbolVector &);
 
 private:
   // A new GenericInfo is pushed for each interface block and generic stmt
@@ -2330,7 +2330,7 @@ static bool IsOperatorOrAssignment(const Symbol &generic) {
 
 // Check that the specifics of this generic are distinguishable from each other
 void InterfaceVisitor::CheckSpecificsAreDistinguishable(
-    const Symbol &generic, const SymbolVector &specifics) {
+    Symbol &generic, const SymbolVector &specifics) {
   auto count{specifics.size()};
   if (specifics.size() < 2) {
     return;
@@ -2356,6 +2356,7 @@ void InterfaceVisitor::CheckSpecificsAreDistinguishable(
       auto &proc2{procs[i2]};
       if (!distinguishable(proc1, proc2)) {
         SayNotDistinguishable(generic, *specifics[i1], *specifics[i2]);
+        context().SetError(generic);
       }
     }
   }

test/semantics/CMakeLists.txt

@@ -98,6 +98,7 @@ set(ERROR_TESTS
   resolve59.f90
   resolve60.f90
   resolve61.f90
+  resolve62.f90
   stop01.f90
   structconst01.f90
   structconst02.f90
@@ -227,6 +228,7 @@ set(MODFILE_TESTS
   modfile29.f90
   modfile30.f90
   modfile31.f90
+  modfile32.f90
 )
 
 set(LABEL_TESTS