[flang] Remove bogus messages for actual/dummy procedure argument compatibility

[klausler]

Summary

Add new IsCompatibleWith() member functions to many classes in evaluate::characteristics
that apply more nuanced compatibility checking for function results, dummy
arguments, and procedure interfaces than the previous tests for complete
equivalence. Use IsCompatibleWith() in semantics for call checking.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Evaluate/characteristics.h

struct DummyDataObject {
   DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyDataObject)
   explicit DummyDataObject(const TypeAndShape &t) : type{t} {}
   explicit DummyDataObject(TypeAndShape &&t) : type{std::move(t)} {}
   explicit DummyDataObject(DynamicType t) : type{t} {}
   bool operator==(const DummyDataObject &) const;
   bool operator!=(const DummyDataObject &that) const {
     return !(*this == that);
   }
+  bool IsCompatibleWith(const DummyDataObject &) const;
   static std::optional<DummyDataObject> Characterize(
       const semantics::Symbol &, FoldingContext &);
   bool CanBePassedViaImplicitInterface() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
   TypeAndShape type;
   std::vector<Expr<SubscriptInteger>> coshape;
   common::Intent intent{common::Intent::Default};
   Attrs attrs;
 };
 
 // 15.3.2.3
 struct DummyProcedure {
   ENUM_CLASS(Attr, Pointer, Optional)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
   DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
   explicit DummyProcedure(Procedure &&);
   bool operator==(const DummyProcedure &) const;
   bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
+  bool IsCompatibleWith(const DummyProcedure &) const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
+
   CopyableIndirection<Procedure> procedure;
   common::Intent intent{common::Intent::Default};
   Attrs attrs;
 };
 
 // 15.3.2.4
 struct AlternateReturn {
   bool operator==(const AlternateReturn &) const { return true; }
struct DummyArgument {
   static std::optional<DummyArgument> FromActual(
       std::string &&, const Expr<SomeType> &, FoldingContext &);
   bool IsOptional() const;
   void SetOptional(bool = true);
   common::Intent GetIntent() const;
   void SetIntent(common::Intent);
   bool CanBePassedViaImplicitInterface() const;
   bool IsTypelessIntrinsicDummy() const;
+  bool IsCompatibleWith(const DummyArgument &) const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
-  // name and pass are not characteristics and so does not participate in
-  // operator== but are needed to determine if procedures are distinguishable
+
+  // name and pass are not characteristics and so do not participate in
+  // compatibility checks, but they are needed to determine whether
+  // procedures are distinguishable
   std::string name;
   bool pass{false}; // is this the PASS argument of its procedure
   std::variant<DummyDataObject, DummyProcedure, AlternateReturn> u;
 };
 
 using DummyArguments = std::vector<DummyArgument>;
 
 // 15.3.3
if (const auto *pp{std::get_if<CopyableIndirection<Procedure>>(&u)}) {
       return nullptr;
     }
   }
   const TypeAndShape *GetTypeAndShape() const {
     return std::get_if<TypeAndShape>(&u);
   }
   void SetType(DynamicType t) { std::get<TypeAndShape>(u).set_type(t); }
   bool CanBeReturnedViaImplicitInterface() const;
+  bool IsCompatibleWith(const FunctionResult &) const;
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   Attrs attrs;
   std::variant<TypeAndShape, CopyableIndirection<Procedure>> u;
 };
 
 // 15.3.1
struct Procedure {
   bool IsElemental() const { return attrs.test(Attr::Elemental); }
   bool IsBindC() const { return attrs.test(Attr::BindC); }
   bool HasExplicitInterface() const {
     return !attrs.test(Attr::ImplicitInterface);
   }
   int FindPassIndex(std::optional<parser::CharBlock>) const;
   bool CanBeCalledViaImplicitInterface() const;
   bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
+  bool IsCompatibleWith(const Procedure &) const;
+
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   std::optional<FunctionResult> functionResult;
   DummyArguments dummyArguments;
   Attrs attrs;
 };
 } // namespace Fortran::evaluate::characteristics
 #endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_

flang/lib/Evaluate/characteristics.cpp

llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
   return o;
 }
 
 bool DummyDataObject::operator==(const DummyDataObject &that) const {
   return type == that.type && attrs == that.attrs && intent == that.intent &&
       coshape == that.coshape;
 }
 
+bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual) const {
+  return type.shape() == actual.type.shape() &&
+      type.type().IsTkCompatibleWith(actual.type.type()) &&
+      attrs == actual.attrs && intent == actual.intent &&
+      coshape == actual.coshape;
+}
+
 static common::Intent GetIntent(const semantics::Attrs &attrs) {
   if (attrs.test(semantics::Attr::INTENT_IN)) {
     return common::Intent::In;
   } else if (attrs.test(semantics::Attr::INTENT_OUT)) {
     return common::Intent::Out;
   } else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
     return common::Intent::InOut;
   } else {

 DummyProcedure::DummyProcedure(Procedure &&p)
     : procedure{new Procedure{std::move(p)}} {}
 
 bool DummyProcedure::operator==(const DummyProcedure &that) const {
   return attrs == that.attrs && intent == that.intent &&
       procedure.value() == that.procedure.value();
 }
 
+bool DummyProcedure::IsCompatibleWith(const DummyProcedure &actual) const {
+  return attrs == actual.attrs && intent == actual.intent &&
+      procedure.value().IsCompatibleWith(actual.procedure.value());
+}
+
 static std::string GetSeenProcs(
     const semantics::UnorderedSymbolSet &seenProcs) {
   // Sort the symbols so that they appear in the same order on all platforms
   auto ordered{semantics::OrderBySourcePosition(seenProcs)};
   std::string result;
   llvm::interleave(
       ordered,
       [&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; },

 }
 
 DummyArgument::~DummyArgument() {}
 
 bool DummyArgument::operator==(const DummyArgument &that) const {
   return u == that.u; // name and passed-object usage are not characteristics
 }
 
+bool DummyArgument::IsCompatibleWith(const DummyArgument &actual) const {
+  if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
+    const auto *actualData{std::get_if<DummyDataObject>(&actual.u)};
+    return actualData && ifaceData->IsCompatibleWith(*actualData);
+  } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
+    const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)};
+    return actualProc && ifaceProc->IsCompatibleWith(*actualProc);
+  } else {
+    return std::holds_alternative<AlternateReturn>(u) &&
+        std::holds_alternative<AlternateReturn>(actual.u);
+  }
+}
+
 static std::optional<DummyArgument> CharacterizeDummyArgument(
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet &seenProcs) {
   auto name{symbol.name().ToString()};
   if (symbol.has<semantics::ObjectEntityDetails>() ||
       symbol.has<semantics::EntityDetails>()) {
     if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
       return DummyArgument{std::move(name), std::move(obj.value())};
if (typeAndShape->Rank() > 0) {
         return true;
       }
     }
   } else {
     return false; // 15.4.2.2(4)(b) - procedure pointer
   }
 }
 
+bool FunctionResult::IsCompatibleWith(const FunctionResult &actual) const {
+  Attrs actualAttrs{actual.attrs};
+  actualAttrs.reset(Attr::Contiguous);
+  if (attrs != actualAttrs) {
+    return false;
+  } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
+    if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
+      if (ifaceTypeShape->shape() != actualTypeShape->shape()) {
+        return false;
+      } else {
+        return ifaceTypeShape->type().IsTkCompatibleWith(
+            actualTypeShape->type());
+      }
+    } else {
+      return false;
+    }
+  } else {
+    const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
+    if (const auto *actualProc{
+            std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
+      return ifaceProc->value().IsCompatibleWith(actualProc->value());
+    } else {
+      return false;
+    }
+  }
+}
+
 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
   attrs.Dump(o, EnumToString);
   std::visit(common::visitors{
                  [&](const TypeAndShape &ts) { ts.Dump(o); },
                  [&](const CopyableIndirection<Procedure> &p) {
                    p.value().Dump(o << " procedure(") << ')';
                  },
              },
       u);
   return o;
 }
 
 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() {}
 
 bool Procedure::operator==(const Procedure &that) const {
   return attrs == that.attrs && functionResult == that.functionResult &&
       dummyArguments == that.dummyArguments;
 }
 
+bool Procedure::IsCompatibleWith(const Procedure &actual) const {
+  // 15.5.2.9(1): if dummy is not pure, actual need not be.
+  Attrs actualAttrs{actual.attrs};
+  if (!attrs.test(Attr::Pure)) {
+    actualAttrs.reset(Attr::Pure);
+  }
+  if (attrs != actualAttrs) {
+    return false;
+  } else if (IsFunction() != actual.IsFunction()) {
+    return false;
+  } else if (IsFunction() &&
+      !functionResult->IsCompatibleWith(*actual.functionResult)) {
+    return false;
+  } else if (dummyArguments.size() != actual.dummyArguments.size()) {
+    return false;
+  } else {
+    for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
+      if (!dummyArguments[j].IsCompatibleWith(actual.dummyArguments[j])) {
+        return false;
+      }
+    }
+    return true;
+  }
+}
+
 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
   int argCount{static_cast<int>(dummyArguments.size())};
   int index{0};
   if (name) {
     while (index < argCount && *name != dummyArguments[index].name.c_str()) {
       ++index;
     }
   }

flang/lib/Semantics/check-call.cpp

if (auto argChars{characteristics::DummyArgument::FromActual(
                   "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
                   argProcSymbol->name());
               return; // avoid piling on with checks below
             } else {
               argInterface.attrs.reset(
                   characteristics::Procedure::Attr::NullPointer);
             }
           }
-          if (!interface.IsPure()) {
-            // 15.5.2.9(1): if dummy is not pure, actual need not be.
-            argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
-          }
           if (interface.HasExplicitInterface()) {
-            if (interface != argInterface) {
+            if (!interface.IsCompatibleWith(argInterface)) {
               // 15.5.2.9(1): Explicit interfaces must match
               if (argInterface.HasExplicitInterface()) {
                 messages.Say(
                     "Actual procedure argument has interface incompatible with %s"_err_en_US,
                     dummyName);
                 return;
               } else if (proc.IsPure()) {
                 messages.Say(
if (auto argChars{characteristics::DummyArgument::FromActual(
             }
           } else { // 15.5.2.9(2,3)
             if (interface.IsSubroutine() && argInterface.IsFunction()) {
               messages.Say(
                   "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
                   dummyName);
             } else if (interface.IsFunction()) {
               if (argInterface.IsFunction()) {
-                if (interface.functionResult != argInterface.functionResult) {
+                if (!interface.functionResult->IsCompatibleWith(
+                        *argInterface.functionResult)) {
                   messages.Say(
                       "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
                       dummyName);
                 }
               } else if (argInterface.IsSubroutine()) {
                 messages.Say(
                     "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
                     dummyName);
if (auto argChars{characteristics::DummyArgument::FromActual(
             dummyName);
       }
     }
     if (interface.HasExplicitInterface() && dummyIsPointer &&
         dummy.intent != common::Intent::In) {
       const Symbol *last{GetLastSymbol(*expr)};
       if (!(last && IsProcedurePointer(*last))) {
         // 15.5.2.9(5) -- dummy procedure POINTER
-        // Interface compatibility has already been checked above by comparison.
+        // Interface compatibility has already been checked above
         messages.Say(
             "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
             dummyName);
       }
     }
   } else {
     messages.Say(
         "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,

flang/test/Semantics/call25.f90

+! RUN: not %flang -fsyntax-only 2>&1 %s | FileCheck %s
+module m
+ contains
+  subroutine subr1(f)
+    character(5) f
+    print *, f('abcde')
+  end subroutine
+  subroutine subr2(f)
+    character(*) f
+    print *, f('abcde')
+  end subroutine
+  character(5) function explicitLength(x)
+    character(5), intent(in) :: x
+    explicitLength = x
+  end function
+  real function notChar(x)
+    character(*), intent(in) :: x
+    notChar = 0
+  end function
+end module
+
+character(*) function assumedLength(x)
+  character(*), intent(in) :: x
+  assumedLength = x
+end function
+
+subroutine subr3(f)
+  character(5) f
+  print *, f('abcde')
+end subroutine
+
+program main
+  use m
+  external assumedlength
+  character(5) :: assumedlength
+  call subr1(explicitLength)
+  call subr1(assumedLength)
+  !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+  call subr1(notChar)
+  call subr2(explicitLength)
+  call subr2(assumedLength)
+  !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+  call subr2(notChar)
+  call subr3(explicitLength)
+  call subr3(assumedLength)
+  !CHECK: Warning: if the procedure's interface were explicit, this reference would be in error:
+  !CHECK: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+  call subr3(notChar)
+end program