[flang] rebase

Original-commit: flang-compiler/f18@2691da3
Reviewed-on: flang-compiler/f18#782
Tree-same-pre-rewrite: false

flang/lib/evaluate/characteristics.cc

@@ -526,6 +526,7 @@ Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
   : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {}
 Procedure::Procedure(DummyArguments &&args, Attrs a)
   : dummyArguments{std::move(args)}, attrs{a} {}
+Procedure::~Procedure() = default;
 
 bool Procedure::operator==(const Procedure &that) const {
   return attrs == that.attrs && dummyArguments == that.dummyArguments &&

flang/lib/evaluate/characteristics.h

@@ -224,6 +224,7 @@ struct Procedure {
   Procedure(FunctionResult &&, DummyArguments &&, Attrs);
   Procedure(DummyArguments &&, Attrs);  // for subroutines and NULL()
   DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
+  ~Procedure();
   bool operator==(const Procedure &) const;
 
   // Characterizes the procedure represented by a symbol, which may be an

flang/lib/evaluate/common.h

@@ -229,12 +229,15 @@ class FoldingContext {
       pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {}
 
   parser::ContextualMessages &messages() { return messages_; }
-  const common::IntrinsicTypeDefaultKinds &defaults() { return defaults_; }
+  const parser::ContextualMessages &messages() const { return messages_; }
+  const common::IntrinsicTypeDefaultKinds &defaults() const {
+    return defaults_;
+  }
   Rounding rounding() const { return rounding_; }
   bool flushSubnormalsToZero() const { return flushSubnormalsToZero_; }
   bool bigEndian() const { return bigEndian_; }
   const semantics::DerivedTypeSpec *pdtInstance() const { return pdtInstance_; }
-  HostIntrinsicProceduresLibrary &hostIntrinsicsLibrary() {
+  const HostIntrinsicProceduresLibrary &hostIntrinsicsLibrary() const {
     return hostIntrinsicsLibrary_;
   }
   const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; }

flang/lib/evaluate/intrinsics-library-templates.h

@@ -176,7 +176,7 @@ template<template<typename> typename ConstantContainer, typename TR,
     typename... TA>
 std::optional<HostProcedureWrapper<ConstantContainer, TR, TA...>>
 HostIntrinsicProceduresLibrary::GetHostProcedureWrapper(
-    const std::string &name) {
+    const std::string &name) const {
   if constexpr (host::HostTypeExists<TR, TA...>()) {
     auto rteProcRange{procedures_.equal_range(name)};
     const TypeCode resTypeCode{typeCodeOf<TR>};

flang/lib/evaluate/intrinsics-library.h

@@ -104,7 +104,7 @@ class HostIntrinsicProceduresLibrary {
   template<template<typename> typename ConstantContainer, typename TR,
       typename... TA>
   std::optional<HostProcedureWrapper<ConstantContainer, TR, TA...>>
-  GetHostProcedureWrapper(const std::string &name);
+  GetHostProcedureWrapper(const std::string &name) const;
 
 private:
   std::multimap<std::string, const HostRuntimeIntrinsicProcedure> procedures_;

flang/lib/evaluate/type.h

@@ -102,6 +102,7 @@ class DynamicType {
       kind_ = ClassKind;
     }
   }
+  CONSTEXPR_CONSTRUCTORS_AND_ASSIGNMENTS(DynamicType)
 
   // A rare use case used for representing the characteristics of an
   // intrinsic function like REAL() that accepts a typeless BOZ literal

flang/lib/semantics/check-call.cc

@@ -307,43 +307,34 @@ static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
     const characteristics::Procedure &proc, evaluate::FoldingContext &context,
     const Scope &scope) {
   auto &messages{context.messages()};
-  std::visit(
-      common::visitors{
-          [&](const characteristics::DummyDataObject &object) {
-            if (const auto *expr{arg.UnwrapExpr()}) {
-              if (auto type{characteristics::TypeAndShape::Characterize(
-                      *expr, context)}) {
-                CheckExplicitDataArg(
-                    object, *expr, *type, proc, context, scope);
-              } else if (object.type.type().IsTypelessIntrinsicArgument() &&
-                  std::holds_alternative<evaluate::BOZLiteralConstant>(
-                      expr->u)) {
-                // ok
-              } else {
-                messages.Say(
-                    "Actual argument is not a variable or typed expression"_err_en_US);
-              }
-            } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
-              // An assumed-type dummy is being forwarded.
-              if (!object.type.type().IsAssumedType()) {
-                messages.Say(
-                    "Assumed-type TYPE(*) '%s' may be associated only with an assumed-TYPE(*) dummy argument"_err_en_US,
-                    assumed->name());
-              }
-            } else {
-              messages.Say(
-                  "Actual argument is not an expression or variable"_err_en_US);
-            }
-          },
-          [&](const characteristics::DummyProcedure &) {
-            // TODO check effective procedure compatibility
-          },
-          [&](const characteristics::AlternateReturn &) {
-            // TODO check alternate return
-          },
-      },
-      dummy.u);
-  return true;  // TODO: return false when error detected
+  if (const auto *object{
+          std::get_if<characteristics::DummyDataObject>(&dummy.u)}) {
+    if (const auto *expr{arg.UnwrapExpr()}) {
+      if (auto type{
+              characteristics::TypeAndShape::Characterize(*expr, context)}) {
+        CheckExplicitDataArg(*object, *expr, *type, proc, context, scope);
+      } else if (object->type.type().IsTypelessIntrinsicArgument() &&
+          std::holds_alternative<evaluate::BOZLiteralConstant>(expr->u)) {
+        // ok
+      } else {
+        messages.Say(
+            "Actual argument is not a variable or typed expression"_err_en_US);
+      }
+    } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
+      // An assumed-type dummy is being forwarded.
+      if (!object->type.type().IsAssumedType()) {
+        messages.Say(
+            "Assumed-type TYPE(*) '%s' may be associated only with an assumed-TYPE(*) dummy argument"_err_en_US,
+            assumed->name());
+      }
+    } else {
+      messages.Say(
+          "Actual argument is not an expression or variable"_err_en_US);
+    }
+  } else {
+    // TODO check actual procedure compatibility
+    // TODO check alternate return
+  }
 }
 
 static void RearrangeArguments(const characteristics::Procedure &proc,
@@ -355,7 +346,6 @@ 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, evaluate::ActualArgument> kwArgs;
   for (auto &x : actuals) {
@@ -367,7 +357,6 @@ 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();
       }
@@ -384,7 +373,6 @@ 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);
           }
@@ -398,49 +386,50 @@ 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, const Scope &scope) {
-  parser::ContextualMessages &messages{context.messages()};
-  if (!RearrangeArguments(proc, actuals, 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, scope)) {
-        return false;
-      }
-    } else if (!dummy.IsOptional()) {
-      if (dummy.name.empty()) {
-        messages.Say(
-            "Dummy argument #%d is not OPTIONAL and is not associated with an "
-            "actual 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 actual argument in this procedure reference"_err_en_US,
-            dummy.name, index);
+parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
+    evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
+    const Scope &scope) {
+  parser::Messages buffer;
+  parser::ContextualMessages messages{context.messages().at(), &buffer};
+  evaluate::FoldingContext localContext{context, messages};
+  RearrangeArguments(proc, actuals, messages);
+  if (buffer.empty()) {
+    int index{0};
+    for (auto &actual : actuals) {
+      const auto &dummy{proc.dummyArguments.at(index++)};
+      if (actual.has_value()) {
+        CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope);
+      } else if (!dummy.IsOptional()) {
+        if (dummy.name.empty()) {
+          messages.Say(
+              "Dummy argument #%d is not OPTIONAL and is not associated with "
+              "an actual 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 actual argument in this procedure reference"_err_en_US,
+              dummy.name, index);
+        }
       }
-      return false;
     }
   }
-  return true;
+  return buffer;
 }
 
 void CheckArguments(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
     const Scope &scope, bool treatingExternalAsImplicit) {
   bool explicitInterface{proc.HasExplicitInterface()};
-  if (explicitInterface()) {
-    CheckExplicitInterface(proc, actuals, context, scope);
+  if (explicitInterface) {
+    auto buffer{CheckExplicitInterface(proc, actuals, context, scope)};
+    if (auto *msgs{context.messages().messages()}) {
+      msgs->Merge(std::move(buffer));
+    }
   }
   if (!explicitInterface || treatingExternalAsImplicit) {
     parser::Messages buffer;

flang/lib/semantics/check-call.h

@@ -20,6 +20,7 @@
 #include "../evaluate/call.h"
 
 namespace Fortran::parser {
+class Messages;
 class ContextualMessages;
 }
 namespace Fortran::evaluate::characteristics {
@@ -41,8 +42,9 @@ void CheckArguments(const evaluate::characteristics::Procedure &,
     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 &);
+// Reports a buffer of errors when not compatible.
+parser::Messages CheckExplicitInterface(
+    const evaluate::characteristics::Procedure &, evaluate::ActualArguments &,
+    const evaluate::FoldingContext &, const Scope &);
 }
 #endif

flang/lib/semantics/expression.cc

@@ -1559,20 +1559,18 @@ static bool CheckCompatibleArguments(
   return true;
 }
 
-const Symbol *ExpressionAnalyzer::ResolveGeneric(
-    const Symbol &symbol, ActualArguments &actuals) {
+const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
+    ActualArguments &actuals, const semantics::Scope &scope) {
   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) &&
+      auto messages{CheckExplicitInterface(
+          *procedure, localActuals, GetFoldingContext(), scope)};
+      if (messages.empty() &&
           CheckCompatibleArguments(*procedure, localActuals)) {
         if (!procedure->IsElemental()) {
           return specific;  // takes priority over elemental match
@@ -1592,7 +1590,8 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(
 
 auto ExpressionAnalyzer::GetCalleeAndArguments(
     const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
-    bool isSubroutine) -> std::optional<CalleeAndArguments> {
+    bool isSubroutine, const semantics::Scope &scope)
+    -> std::optional<CalleeAndArguments> {
   return std::visit(
       common::visitors{
           [&](const parser::Name &n) -> std::optional<CalleeAndArguments> {
@@ -1615,7 +1614,7 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(
             }
             CheckForBadRecursion(n.source, ultimate);
             if (ultimate.has<semantics::GenericDetails>()) {
-              symbol = ResolveGeneric(ultimate, arguments);
+              symbol = ResolveGeneric(ultimate, arguments, scope);
             }
             if (symbol) {
               return CalleeAndArguments{
@@ -1721,7 +1720,8 @@ MaybeExpr ExpressionAnalyzer::AnalyzeCall(
     // TODO: map non-intrinsic generic procedure to specific procedure
     if (std::optional<CalleeAndArguments> callee{
             GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
-                std::move(*arguments), isSubroutine)}) {
+                std::move(*arguments), isSubroutine,
+                context_.FindScope(call.source))}) {
       if (isSubroutine) {
         CheckCall(call.source, callee->procedureDesignator, callee->arguments);
         // TODO: Package the subroutine call as an expr in the parse tree

flang/lib/semantics/expression.h

@@ -326,10 +326,11 @@ 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 &, ActualArguments &, const semantics::Scope &);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::ProcedureDesignator &, ActualArguments &&,
-      bool isSubroutine);
+      bool isSubroutine, const semantics::Scope &);
 
   void CheckForBadRecursion(parser::CharBlock, const semantics::Symbol &);
   bool EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory,