[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

   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;

   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;

   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;

   }
   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;
 

   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;

flang/lib/Evaluate/characteristics.cpp

       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;

       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

   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) {

   }
 }
 
+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{

       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};

flang/lib/Semantics/check-call.cpp

                   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(

                   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);

       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);

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