[flang] Refine semantic checks for procedure pointer assignment

[klausler]

Summary

Some procedure pointers and EXTERNAL procedures have neither
explicit interfaces nor result types; these procedures are obviously
not known to be functions, but they could be, so semantics must not
assume that they are necessarily subroutines. Refine the procedure
pointer / dummy procedure compatibility check to handle these more
ambiguous cases and not elicit inappropriate error messages.

[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;
+  bool IsCompatibleWith(
+      const DummyDataObject &, std::string *whyNot = nullptr) 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;
+  bool IsCompatibleWith(
+      const DummyProcedure &, std::string *whyNot = nullptr) 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 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;
+  bool IsCompatibleWith(
+      const DummyArgument &, std::string *whyNot = nullptr) const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   // 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;
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;
+  bool IsCompatibleWith(
+      const FunctionResult &, std::string *whyNot = nullptr) 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;
+  bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr) 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/include/flang/Evaluate/tools.h

template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
   return !UnexpandabilityFindingVisitor{}(expr);
 }
 
 // Common handling for procedure pointer compatibility of left- and right-hand
 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
 // message that needs to be augmented by the names of the left and right sides
 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     const std::optional<characteristics::Procedure> &lhsProcedure,
-    const characteristics::Procedure *rhsProcedure);
+    const characteristics::Procedure *rhsProcedure,
+    std::string &whyNotCompatible);
 
 // Scalar constant expansion
 class ScalarConstantExpander {
 public:
   explicit ScalarConstantExpander(ConstantSubscripts &&extents)
       : extents_{std::move(extents)} {}
   ScalarConstantExpander(
       ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)

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 bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
+  // TODO: Validate more than just compatible ranks
+  return GetRank(x) == GetRank(y);
+}
+
+bool DummyDataObject::IsCompatibleWith(
+    const DummyDataObject &actual, std::string *whyNot) const {
+  if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object shapes";
+    }
+    return false;
+  }
+  if (!type.type().IsTkCompatibleWith(actual.type.type())) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object types: "s +
+          type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
+    }
+    return false;
+  }
+  if (attrs != actual.attrs) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object attributes";
+    }
+    return false;
+  }
+  if (intent != actual.intent) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object intents";
+    }
+    return false;
+  }
+  if (coshape != actual.coshape) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object coshapes";
+    }
+    return false;
+  }
+  return true;
 }
 
 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)) {

 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());
+bool DummyProcedure::IsCompatibleWith(
+    const DummyProcedure &actual, std::string *whyNot) const {
+  if (attrs != actual.attrs) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy procedure attributes";
+    }
+    return false;
+  }
+  if (intent != actual.intent) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy procedure intents";
+    }
+    return false;
+  }
+  if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
+    }
+    return false;
+  }
+  return true;
 }
 
 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(

 }
 
 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 {
+bool DummyArgument::IsCompatibleWith(
+    const DummyArgument &actual, std::string *whyNot) const {
   if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
-    const auto *actualData{std::get_if<DummyDataObject>(&actual.u)};
-    return actualData && ifaceData->IsCompatibleWith(*actualData);
+    if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
+      return ifaceData->IsCompatibleWith(*actualData, whyNot);
+    }
+    if (whyNot) {
+      *whyNot = "one dummy argument is an object, the other is not";
+    }
   } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
-    const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)};
-    return actualProc && ifaceProc->IsCompatibleWith(*actualProc);
+    if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) {
+      return ifaceProc->IsCompatibleWith(*actualProc, whyNot);
+    }
+    if (whyNot) {
+      *whyNot = "one dummy argument is a procedure, the other is not";
+    }
   } else {
-    return std::holds_alternative<AlternateReturn>(u) &&
-        std::holds_alternative<AlternateReturn>(actual.u);
+    CHECK(std::holds_alternative<AlternateReturn>(u));
+    if (std::holds_alternative<AlternateReturn>(actual.u)) {
+      return true;
     }
+    if (whyNot) {
+      *whyNot = "one dummy argument is an alternate return, the other is not";
+    }
+  }
+  return false;
 }
 
 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 (typeAndShape->Rank() > 0) {
         return true;
       }
     }
   } else {
     return false; // 15.4.2.2(4)(b) - procedure pointer
   }
 }
 
-bool FunctionResult::IsCompatibleWith(const FunctionResult &actual) const {
+bool FunctionResult::IsCompatibleWith(
+    const FunctionResult &actual, std::string *whyNot) const {
   Attrs actualAttrs{actual.attrs};
+  if (!attrs.test(Attr::Contiguous)) {
     actualAttrs.reset(Attr::Contiguous);
+  }
   if (attrs != actualAttrs) {
-    return false;
+    if (whyNot) {
+      *whyNot = "function results have incompatible attributes";
+    }
   } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
     if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
       if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
-        return false;
+        if (whyNot) {
+          *whyNot = "function results have distinct ranks";
+        }
       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
           ifaceTypeShape->shape() != actualTypeShape->shape()) {
-        return false;
+        if (whyNot) {
+          *whyNot = "function results have distinct extents";
+        }
+      } else if (!ifaceTypeShape->type().IsTkCompatibleWith(
+                     actualTypeShape->type())) {
+        if (whyNot) {
+          *whyNot = "function results have incompatible types: "s +
+              ifaceTypeShape->type().AsFortran() + " vs "s +
+              actualTypeShape->type().AsFortran();
+        }
       } else {
-        return ifaceTypeShape->type().IsTkCompatibleWith(
-            actualTypeShape->type());
+        return true;
       }
     } else {
-      return false;
+      if (whyNot) {
+        *whyNot = "function result type and shape are not known";
+      }
     }
   } else {
     const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
+    CHECK(ifaceProc != nullptr);
     if (const auto *actualProc{
             std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
-      return ifaceProc->value().IsCompatibleWith(actualProc->value());
+      if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) {
+        return true;
+      }
+      if (whyNot) {
+        *whyNot =
+            "function results are incompatible procedure pointers: "s + *whyNot;
+      }
     } else {
-      return false;
+      if (whyNot) {
+        *whyNot =
+            "one function result is a procedure pointer, the other is not";
+      }
     }
   }
+  return false;
 }
 
 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
   attrs.Dump(o, EnumToString);
   common::visit(common::visitors{
                     [&](const TypeAndShape &ts) { ts.Dump(o); },
                     [&](const CopyableIndirection<Procedure> &p) {
                       p.value().Dump(o << " procedure(") << ')';
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 {
+bool Procedure::IsCompatibleWith(
+    const Procedure &actual, std::string *whyNot) const {
   // 15.5.2.9(1): if dummy is not pure, actual need not be.
+  // Ditto with elemental.
   Attrs actualAttrs{actual.attrs};
   if (!attrs.test(Attr::Pure)) {
     actualAttrs.reset(Attr::Pure);
   }
+  if (!attrs.test(Attr::Elemental)) {
+    actualAttrs.reset(Attr::Elemental);
+  }
   if (attrs != actualAttrs) {
-    return false;
-  } else if (IsFunction() != actual.IsFunction()) {
-    return false;
-  } else if (IsFunction() &&
-      !functionResult->IsCompatibleWith(*actual.functionResult)) {
-    return false;
+    if (whyNot) {
+      *whyNot = "incompatible procedure attributes";
+    }
+  } else if ((IsFunction() && actual.IsSubroutine()) ||
+      (IsSubroutine() && actual.IsFunction())) {
+    if (whyNot) {
+      *whyNot =
+          "incompatible procedures: one is a function, the other a subroutine";
+    }
+  } else if (functionResult && actual.functionResult &&
+      !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
   } else if (dummyArguments.size() != actual.dummyArguments.size()) {
-    return false;
+    if (whyNot) {
+      *whyNot = "distinct numbers of dummy arguments";
+    }
   } else {
     for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
-      if (!dummyArguments[j].IsCompatibleWith(actual.dummyArguments[j])) {
+      if (!dummyArguments[j].IsCompatibleWith(
+              actual.dummyArguments[j], whyNot)) {
+        if (whyNot) {
+          *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
+              ": "s + *whyNot;
+        }
         return false;
       }
     }
     return true;
   }
+  return false;
 }
 
 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;
if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
     return true;
   }
 }
 
 llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
   attrs.Dump(o, EnumToString);
   if (functionResult) {
     functionResult->Dump(o << "TYPE(") << ") FUNCTION";
-  } else {
+  } else if (attrs.test(Attr::Subroutine)) {
     o << "SUBROUTINE";
+  } else {
+    o << "EXTERNAL";
   }
   char sep{'('};
   for (const auto &dummy : dummyArguments) {
     dummy.Dump(o << sep);
     sep = ',';
   }
   return o << (sep == '(' ? "()" : ")");
 }

flang/lib/Evaluate/intrinsics.cpp

if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
               }
               if (IsProcedure(*pointerSymbol)) {
                 pointerProc = characteristics::Procedure::Characterize(
                     *pointerSymbol, context);
               }
               if (pointerProc) {
                 if (targetProc) {
                   // procedure pointer and procedure target
+                  std::string whyNot;
                   if (std::optional<parser::MessageFixedText> msg{
                           CheckProcCompatibility(
-                              isCall, pointerProc, &*targetProc)}) {
+                              isCall, pointerProc, &*targetProc, whyNot)}) {
                     AttachDeclaration(
                         context.messages().Say(std::move(*msg),
                             "pointer '" + pointerSymbol->name().ToString() +
                                 "'",
-                            targetName),
+                            targetName, whyNot),
                         *pointerSymbol);
                   }
                 } else {
                   // procedure pointer and object target
                   if (!IsNullPointer(*targetExpr)) {
                     AttachDeclaration(
                         context.messages().Say(
                             "POINTER= argument '%s' is a procedure "

flang/lib/Evaluate/tools.cpp

std::optional<std::string> FindImpureCall(
     FoldingContext &context, const Expr<SomeType> &expr) {
   return FindImpureCallHelper{context}(expr);
 }
 std::optional<std::string> FindImpureCall(
     FoldingContext &context, const ProcedureRef &proc) {
   return FindImpureCallHelper{context}(proc);
 }
 
-// Compare procedure characteristics for equality except that rhs may be
-// Pure or Elemental when lhs is not.
-static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
-    const characteristics::Procedure &rhs) {
-  using Attr = characteristics::Procedure::Attr;
-  auto lhsAttrs{lhs.attrs};
-  lhsAttrs.set(
-      Attr::Pure, lhs.attrs.test(Attr::Pure) || rhs.attrs.test(Attr::Pure));
-  lhsAttrs.set(Attr::Elemental,
-      lhs.attrs.test(Attr::Elemental) || rhs.attrs.test(Attr::Elemental));
-  return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
-      lhs.dummyArguments == rhs.dummyArguments;
-}
-
 // Common handling for procedure pointer compatibility of left- and right-hand
 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
 // message that needs to be augmented by the names of the left and right sides
+// and the content of the "whyNotCompatible" string.
 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     const std::optional<characteristics::Procedure> &lhsProcedure,
-    const characteristics::Procedure *rhsProcedure) {
+    const characteristics::Procedure *rhsProcedure,
+    std::string &whyNotCompatible) {
   std::optional<parser::MessageFixedText> msg;
   if (!lhsProcedure) {
     msg = "In assignment to object %s, the target '%s' is a procedure"
           " designator"_err_en_US;
   } else if (!rhsProcedure) {
     msg = "In assignment to procedure %s, the characteristics of the target"
           " procedure '%s' could not be determined"_err_en_US;
-  } else if (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
+  } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible)) {
     // OK
   } else if (isCall) {
     msg = "Procedure %s associated with result of reference to function '%s'"
-          " that is an incompatible procedure pointer"_err_en_US;
+          " that is an incompatible procedure pointer: %s"_err_en_US;
   } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
     msg = "PURE procedure %s may not be associated with non-PURE"
           " procedure designator '%s'"_err_en_US;
-  } else if (lhsProcedure->IsFunction() && !rhsProcedure->IsFunction()) {
+  } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
     msg = "Function %s may not be associated with subroutine"
           " designator '%s'"_err_en_US;
-  } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
+  } else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
     msg = "Subroutine %s may not be associated with function"
           " designator '%s'"_err_en_US;
   } else if (lhsProcedure->HasExplicitInterface() &&
       !rhsProcedure->HasExplicitInterface()) {
     // Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer
     // with an explicit interface with a procedure whose characteristics don't
     // match.  That's the case if the target procedure has an implicit
     // interface.  But this case is allowed by several other compilers as long
     // as the explicit interface can be called via an implicit interface.
     if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {
       msg = "Procedure %s with explicit interface that cannot be called via "
             "an implicit interface cannot be associated with procedure "
             "designator with an implicit interface"_err_en_US;
     }
   } else if (!lhsProcedure->HasExplicitInterface() &&
       rhsProcedure->HasExplicitInterface()) {
     // OK if the target can be called via an implicit interface
     if (!rhsProcedure->CanBeCalledViaImplicitInterface()) {
       msg = "Procedure %s with implicit interface may not be associated "
             "with procedure designator '%s' with explicit interface that "
             "cannot be called via an implicit interface"_err_en_US;
     }
   } else {
     msg = "Procedure %s associated with incompatible procedure"
-          " designator '%s'"_err_en_US;
+          " designator '%s': %s"_err_en_US;
   }
   return msg;
 }
 
 // GetLastPointerSymbol()
 static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
   return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
 }

flang/lib/Semantics/check-call.cpp

if (auto argChars{characteristics::DummyArgument::FromActual(
                   argProcSymbol->name());
               return; // avoid piling on with checks below
             } else {
               argInterface.attrs.reset(
                   characteristics::Procedure::Attr::NullPointer);
             }
           }
           if (interface.HasExplicitInterface()) {
-            if (!interface.IsCompatibleWith(argInterface)) {
+            std::string whyNot;
+            if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
               // 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);
+                    "Actual procedure argument has interface incompatible with %s: %s"_err_en_US,
+                    dummyName, whyNot);
                 return;
               } else if (proc.IsPure()) {
                 messages.Say(
                     "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
                     dummyName);
               } else {
                 messages.Say(
                     "Actual procedure argument has an implicit interface "

flang/lib/Semantics/pointer-assignment.cpp

if (msg) {
     return false;
   }
   return true;
 }
 
 // Common handling for procedure pointer right-hand sides
 bool PointerAssignmentChecker::Check(
     parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
-  if (std::optional<MessageFixedText> msg{
-          evaluate::CheckProcCompatibility(isCall, procedure_, rhsProcedure)}) {
-    Say(std::move(*msg), description_, rhsName);
+  std::string whyNot;
+  if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
+          isCall, procedure_, rhsProcedure, whyNot)}) {
+    Say(std::move(*msg), description_, rhsName, whyNot);
     return false;
   }
   return true;
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
   if (auto chars{Procedure::Characterize(d, context_)}) {
     return Check(d.GetName(), false, &*chars);

flang/test/Semantics/assign03.f90

subroutine s5
     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
     p_pure => f_impureElemental1
 
     !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
     sp_pure => s_impure1
     sp_pure => s_pure1 ! OK, same characteristics
     sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
 
-    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2'
+    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2': incompatible dummy argument #1: incompatible dummy data object intents
     p_impure => f_impure2
-    !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2'
+    !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
     p_pure => f_pure2
-    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2'
+    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible dummy argument #1: incompatible dummy data object attributes
     p_impure => f_elemental2
 
-    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2'
+    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes
     sp_impure => s_impure2
-    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2'
+    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2': incompatible dummy argument #1: incompatible dummy data object intents
     sp_impure => s_pure2
-    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2'
+    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': distinct numbers of dummy arguments
     sp_pure => s_elemental2
 
     !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
     p_impure => s_impure1
 
     !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
     sp_impure => f_impure1
 
contains
   ! 10.2.2.4(5)
   subroutine s7
     procedure(real) :: f_external
     external :: s_external
     procedure(), pointer :: p_s
     procedure(real), pointer :: p_f
     p_f => f_external
     p_s => s_external
-    !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
+    !Ok: p_s has no interface
     p_s => f_external
-    !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
+    !Ok: s_external has no interface
     p_f => s_external
   end
 
   ! C1017: bounds-spec
   subroutine s8
     real, target :: x(10, 10)
     real, pointer :: p(:, :)
     p(2:,3:) => x

flang/test/Semantics/associated.f90

subroutine test()
     lvar = associated(intProcPointer1, null()) ! ok
     intPointerVar1 => null(intPointerVar1) ! ok
     lvar = associated (intPointerVar1, null(intPointerVar1)) ! ok
 
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
     intprocPointer1 => intVar
     !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
     lVar = associated(intprocPointer1, intVar)
-    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
     intProcPointer1 => elementalProc
-    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
     lvar = associated(intProcPointer1, elementalProc)
     !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
     lvar = associated (intPointerVar1, intFunc)
     !ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
     intPointerVar1 => intFunc
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
     intProcPointer1 => targetIntVar1
     !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
     lvar = associated (intProcPointer1, targetIntVar1)
-    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
     intProcPointer1 => null(mold=realProcPointer1)
-    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer
+    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
     lvar = associated(intProcPointer1, null(mold=realProcPointer1))
     !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
     pureFuncPointer => intProc
     !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
     lvar = associated(pureFuncPointer, intProc)
-    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
     realProcPointer1 => intProc
-    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
     lvar = associated(realProcPointer1, intProc)
     subProcPointer => externalProc ! OK to associate a procedure pointer  with an explicit interface to a procedure with an implicit interface
     lvar = associated(subProcPointer, externalProc) ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
     !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
     subProcPointer => intProc
     !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
     lvar = associated(subProcPointer, intProc)
     !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'

flang/test/Semantics/call09.f90

contains
   subroutine test1 ! 15.5.2.9(5)
     intrinsic :: sin
     procedure(realfunc), pointer :: p
     procedure(intfunc), pointer :: ip
     integer, pointer :: intPtr
     p => realfunc
     ip => intfunc
     call s01(realfunc) ! ok
-    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
     call s01(intfunc)
     call s01(p) ! ok
     call s01(procptr()) ! ok
-    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
     call s01(intprocptr())
     call s01(null()) ! ok
     call s01(null(p)) ! ok
-    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
     call s01(null(ip))
     call s01(sin) ! ok
     !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
     call s01(null(intPtr))
     !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
     call s01(B"0101")
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(realfunc)
     call s02(p) ! ok
-    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
     call s02(ip)
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(procptr())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(null())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(null(p))
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)

flang/test/Semantics/call20.f90

! are correctly validated against actual arguments explicit interface.
   end interface
 
   ! OK
   call foo(abs)
 
   ! OK
   call foo2(dabs)
 
-  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f='
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have incompatible types: REAL(4) vs REAL(8)
   call foo(dabs)
 
-  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f='
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have incompatible types: REAL(8) vs REAL(4)
   call foo2(abs)
 end

flang/test/Semantics/null01.f90

subroutine test
   dt0x = dt0(ip0=null(ip0))
   dt0x = dt0(ip0=null(mold=ip0))
   !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)'
   dt0x = dt0(ip0=null(mold=rp0))
   !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)'
   dt1x = dt1(ip1=null(mold=rp1))
   dt2x = dt2(pps0=null())
   dt2x = dt2(pps0=null(mold=dt2x%pps0))
-  !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer
+  !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
   dt2x = dt2(pps0=null(mold=dt3x%pps1))
-  !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+  !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
   dt3x = dt3(pps1=null(mold=dt2x%pps0))
   dt3x = dt3(pps1=null(mold=dt3x%pps1))
   call canbenull(null(), null()) ! fine
   call canbenull(null(mold=ip0), null(mold=rp0)) ! fine
   !ERROR: Null pointer argument requires an explicit interface
   call implicit(null())
   !ERROR: Null pointer argument requires an explicit interface
   call implicit(null(mold=ip0))
 end subroutine test

flang/test/Semantics/resolve46.f90

program main
   procedure(chrcmp), pointer :: s => llt
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
   procedure(cos), pointer :: t => bessel_j0
   procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
   p => alog10 ! ditto, but already declared intrinsic
   p => cos ! ditto, but also generic
   p => tan ! a generic & an unrestricted specific, not already declared
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod'
+  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod': function results have incompatible types: REAL(4) vs INTEGER(4)
   p => mod
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index'
+  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index': function results have incompatible types: REAL(4) vs INTEGER(4)
   p => index
   !ERROR: 'bessel_j0' is not an unrestricted specific intrinsic procedure
   p => bessel_j0
   !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
   u => llt
 end program main