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

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.

Differential Revision: https://reviews.llvm.org/D120844

diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 4c9f946..3bd11da 100644 (file)
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -190,6 +190,7 @@ struct DummyDataObject {
   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;
@@ -208,7 +209,9 @@ struct 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;
@@ -240,9 +243,12 @@ struct DummyArgument {
   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;
@@ -278,6 +284,7 @@ struct FunctionResult {
   }
   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;
 
@@ -322,6 +329,8 @@ struct Procedure {
   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;

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 40263f6..b0a130d 100644 (file)
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -254,6 +254,13 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
       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;
@@ -336,6 +343,11 @@ bool DummyProcedure::operator==(const DummyProcedure &that) const {
       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
@@ -535,6 +547,19 @@ 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) {
@@ -744,6 +769,33 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
   }
 }
 
+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{
@@ -768,6 +820,31 @@ bool Procedure::operator==(const Procedure &that) const {
       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};

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index d55efa8..c942bb3 100644 (file)
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -561,12 +561,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
                   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(
@@ -592,7 +588,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
                   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);
@@ -626,7 +623,7 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
       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);

diff --git a/flang/test/Semantics/call25.f90 b/flang/test/Semantics/call25.f90
new file mode 100644 (file)
index 0000000..746c402
--- /dev/null
+++ b/flang/test/Semantics/call25.f90
@@ -0,0 +1,49 @@
+! 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