[flang] Improve procedure interface compatibility checking for dummy …

flang/include/flang/Common/Fortran-features.h

@@ -53,7 +53,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     ShortCharacterActual, ExprPassedToVolatile, ImplicitInterfaceActual,
     PolymorphicTransferArg, PointerComponentTransferArg, TransferSizePresence,
     F202XAllocatableBreakingChange, DimMustBePresent, CommonBlockPadding,
-    LogicalVsCBool, BindCCharLength)
+    LogicalVsCBool, BindCCharLength, ProcDummyArgShapes)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

flang/include/flang/Evaluate/characteristics.h

@@ -54,7 +54,8 @@ bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &,
 // Shapes of function results and dummy arguments have to have
 // the same rank, the same deferred dimensions, and the same
 // values for explicit dimensions when constant.
-bool ShapesAreCompatible(const Shape &, const Shape &);
+bool ShapesAreCompatible(
+    const Shape &, const Shape &, bool *possibleWarning = nullptr);
 
 class TypeAndShape {
 public:
@@ -222,8 +223,8 @@ struct DummyDataObject {
   bool operator!=(const DummyDataObject &that) const {
     return !(*this == that);
   }
-  bool IsCompatibleWith(
-      const DummyDataObject &, std::string *whyNot = nullptr) const;
+  bool IsCompatibleWith(const DummyDataObject &, std::string *whyNot = nullptr,
+      std::optional<std::string> *warning = nullptr) const;
   static std::optional<DummyDataObject> Characterize(
       const semantics::Symbol &, FoldingContext &);
   bool CanBePassedViaImplicitInterface() const;
@@ -283,8 +284,8 @@ struct DummyArgument {
   void SetIntent(common::Intent);
   bool CanBePassedViaImplicitInterface() const;
   bool IsTypelessIntrinsicDummy() const;
-  bool IsCompatibleWith(
-      const DummyArgument &, std::string *whyNot = nullptr) const;
+  bool IsCompatibleWith(const DummyArgument &, std::string *whyNot = nullptr,
+      std::optional<std::string> *warning = nullptr) const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   // name and pass are not characteristics and so do not participate in
@@ -379,7 +380,8 @@ struct Procedure {
   bool CanBeCalledViaImplicitInterface() const;
   bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
   bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr,
-      const SpecificIntrinsic * = nullptr) const;
+      const SpecificIntrinsic * = nullptr,
+      std::optional<std::string> *warning = nullptr) const;
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 

flang/include/flang/Evaluate/tools.h

@@ -1082,11 +1082,12 @@ bool IsExpandableScalar(const Expr<T> &expr, FoldingContext &context,
 
 // 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
+// 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 SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible);
+    const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
+    std::optional<std::string> &warning);
 
 // Scalar constant expansion
 class ScalarConstantExpander {
@@ -1178,6 +1179,12 @@ class ArrayConstantBoundChanger {
   ConstantSubscripts &&lbounds_;
 };
 
+// Predicate: should two expressions be considered identical for the purposes
+// of determining whether two procedure interfaces are compatible, modulo
+// naming of corresponding dummy arguments?
+std::optional<bool> AreEquivalentInInterface(
+    const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
@@ -1254,6 +1261,8 @@ bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
 
 common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
 
+std::optional<int> GetDummyArgumentNumber(const Symbol *);
+
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/Evaluate/characteristics.cpp

@@ -38,18 +38,23 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst,
 // Shapes of function results and dummy arguments have to have
 // the same rank, the same deferred dimensions, and the same
 // values for explicit dimensions when constant.
-bool ShapesAreCompatible(const Shape &x, const Shape &y) {
+bool ShapesAreCompatible(
+    const Shape &x, const Shape &y, bool *possibleWarning) {
   if (x.size() != y.size()) {
     return false;
   }
   auto yIter{y.begin()};
   for (const auto &xDim : x) {
     const auto &yDim{*yIter++};
-    if (xDim) {
-      if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
-        return false;
+    if (xDim && yDim) {
+      if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) {
+        if (!*equiv) {
+          return false;
+        }
+      } else if (possibleWarning) {
+        *possibleWarning = true;
       }
-    } else if (yDim) {
+    } else if (xDim || yDim) {
       return false;
     }
   }
@@ -270,35 +275,19 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
 bool DummyDataObject::operator==(const DummyDataObject &that) const {
   return type == that.type && attrs == that.attrs && intent == that.intent &&
       coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
-  ;
-}
-
-static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
-  int n{GetRank(x)};
-  if (n != GetRank(y)) {
-    return false;
-  }
-  auto xIter{x.begin()};
-  auto yIter{y.begin()};
-  for (; n-- > 0; ++xIter, ++yIter) {
-    if (auto xVal{ToInt64(*xIter)}) {
-      if (auto yVal{ToInt64(*yIter)}) {
-        if (*xVal != *yVal) {
-          return false;
-        }
-      }
-    }
-  }
-  return true;
 }
 
-bool DummyDataObject::IsCompatibleWith(
-    const DummyDataObject &actual, std::string *whyNot) const {
-  if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
+bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
+    std::string *whyNot, std::optional<std::string> *warning) const {
+  bool possibleWarning{false};
+  if (!ShapesAreCompatible(
+          type.shape(), actual.type.shape(), &possibleWarning)) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object shapes";
     }
     return false;
+  } else if (warning && possibleWarning) {
+    *warning = "distinct dummy data object shapes";
   }
   // Treat deduced dummy character type as if it were assumed-length character
   // to avoid useless "implicit interfaces have distinct type" warnings from
@@ -748,11 +737,11 @@ 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, std::string *whyNot) const {
+bool DummyArgument::IsCompatibleWith(const DummyArgument &actual,
+    std::string *whyNot, std::optional<std::string> *warning) const {
   if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
     if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
-      return ifaceData->IsCompatibleWith(*actualData, whyNot);
+      return ifaceData->IsCompatibleWith(*actualData, whyNot, warning);
     }
     if (whyNot) {
       *whyNot = "one dummy argument is an object, the other is not";
@@ -1181,7 +1170,8 @@ bool Procedure::operator==(const Procedure &that) const {
 }
 
 bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
-    const SpecificIntrinsic *specificIntrinsic) const {
+    const SpecificIntrinsic *specificIntrinsic,
+    std::optional<std::string> *warning) const {
   // 15.5.2.9(1): if dummy is not pure, actual need not be.
   // Ditto with elemental.
   Attrs actualAttrs{actual.attrs};
@@ -1226,13 +1216,17 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
       //   subroutine s1(base); subroutine s2(extended)
       //   procedure(s1), pointer :: p
       //   p => s2 ! an error, s2 is more restricted, can't handle "base"
+      std::optional<std::string> gotWarning;
       if (!actual.dummyArguments[j].IsCompatibleWith(
-              dummyArguments[j], whyNot)) {
+              dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) {
         if (whyNot) {
           *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
               ": "s + *whyNot;
         }
         return false;
+      } else if (warning && !*warning && gotWarning) {
+        *warning = "possibly incompatible dummy argument #"s +
+            std::to_string(j + 1) + ": "s + std::move(*gotWarning);
       }
     }
     return true;

flang/lib/Evaluate/tools.cpp

@@ -1082,7 +1082,8 @@ std::optional<std::string> FindImpureCall(
 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     const std::optional<characteristics::Procedure> &lhsProcedure,
     const characteristics::Procedure *rhsProcedure,
-    const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) {
+    const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
+    std::optional<std::string> &warning) {
   std::optional<parser::MessageFixedText> msg;
   if (!lhsProcedure) {
     msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -1096,8 +1097,8 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
           *rhsProcedure->functionResult, &whyNotCompatible)) {
     msg =
         "Function %s associated with incompatible function designator '%s': %s"_err_en_US;
-  } else if (lhsProcedure->IsCompatibleWith(
-                 *rhsProcedure, &whyNotCompatible, specificIntrinsic)) {
+  } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible,
+                 specificIntrinsic, &warning)) {
     // OK
   } else if (isCall) {
     msg = "Procedure %s associated with result of reference to function '%s'"
@@ -1275,6 +1276,83 @@ std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
   }
 }
 
+// Extracts a whole symbol being used as a bound of a dummy argument,
+// possibly wrapped with parentheses or MAX(0, ...).
+template <int KIND>
+static const Symbol *GetBoundSymbol(
+    const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
+  using T = Type<TypeCategory::Integer, KIND>;
+  return common::visit(
+      common::visitors{
+          [](const Extremum<T> &max) -> const Symbol * {
+            if (max.ordering == Ordering::Greater) {
+              if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {
+                return GetBoundSymbol(max.right());
+              }
+            }
+            return nullptr;
+          },
+          [](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },
+          [](const Designator<T> &x) -> const Symbol * {
+            if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {
+              return &**ref;
+            }
+            return nullptr;
+          },
+          [](const Convert<T, TypeCategory::Integer> &x) {
+            return common::visit(
+                [](const auto &y) -> const Symbol * {
+                  using yType = std::decay_t<decltype(y)>;
+                  using yResult = typename yType::Result;
+                  if constexpr (yResult::kind <= KIND) {
+                    return GetBoundSymbol(y);
+                  } else {
+                    return nullptr;
+                  }
+                },
+                x.left().u);
+          },
+          [](const auto &) -> const Symbol * { return nullptr; },
+      },
+      expr.u);
+}
+
+std::optional<bool> AreEquivalentInInterface(
+    const Expr<SubscriptInteger> &x, const Expr<SubscriptInteger> &y) {
+  auto xVal{ToInt64(x)};
+  auto yVal{ToInt64(y)};
+  if (xVal && yVal) {
+    return *xVal == *yVal;
+  } else if (xVal || yVal) {
+    return false;
+  }
+  const Symbol *xSym{GetBoundSymbol(x)};
+  const Symbol *ySym{GetBoundSymbol(y)};
+  if (xSym && ySym) {
+    if (&xSym->GetUltimate() == &ySym->GetUltimate()) {
+      return true; // USE/host associated same symbol
+    }
+    auto xNum{semantics::GetDummyArgumentNumber(xSym)};
+    auto yNum{semantics::GetDummyArgumentNumber(ySym)};
+    if (xNum && yNum) {
+      if (*xNum == *yNum) {
+        auto xType{DynamicType::From(*xSym)};
+        auto yType{DynamicType::From(*ySym)};
+        return xType && yType && xType->IsEquivalentTo(*yType);
+      }
+    }
+    return false;
+  } else if (xSym || ySym) {
+    return false;
+  }
+  // Neither expression is an integer constant or a whole symbol.
+  if (x == y) {
+    return true;
+  } else {
+    return std::nullopt; // not sure
+  }
+}
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
@@ -1788,4 +1866,23 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
   return result;
 }
 
+std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {
+  if (symbol) {
+    if (IsDummy(*symbol)) {
+      if (const Symbol * subpSym{symbol->owner().symbol()}) {
+        if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {
+          int j{0};
+          for (const Symbol *dummy : subp->dummyArgs()) {
+            if (dummy == symbol) {
+              return j;
+            }
+            ++j;
+          }
+        }
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/check-call.cpp

@@ -968,7 +968,9 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
           }
           if (interface.HasExplicitInterface()) {
             std::string whyNot;
-            if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
+            std::optional<std::string> warning;
+            if (!interface.IsCompatibleWith(argInterface, &whyNot,
+                    /*specificIntrinsic=*/nullptr, &warning)) {
               // 15.5.2.9(1): Explicit interfaces must match
               if (argInterface.HasExplicitInterface()) {
                 messages.Say(
@@ -985,6 +987,11 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
                     "Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
                     dummyName);
               }
+            } else if (warning &&
+                context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
+              messages.Say(
+                  "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
+                  dummyName, std::move(*warning));
             }
           } else { // 15.5.2.9(2,3)
             if (interface.IsSubroutine() && argInterface.IsFunction()) {
@@ -1348,16 +1355,25 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
                         *targetExpr, foldingContext)}) {
                   bool isCall{!!UnwrapProcedureRef(*targetExpr)};
                   std::string whyNot;
+                  std::optional<std::string> warning;
                   const auto *targetProcDesignator{
                       evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
                           *targetExpr)};
                   const evaluate::SpecificIntrinsic *specificIntrinsic{
                       targetProcDesignator
                           ? targetProcDesignator->GetSpecificIntrinsic()
                           : nullptr};
-                  if (std::optional<parser::MessageFixedText> msg{
-                          CheckProcCompatibility(isCall, pointerProc,
-                              &*targetProc, specificIntrinsic, whyNot)}) {
+                  std::optional<parser::MessageFixedText> msg{
+                      CheckProcCompatibility(isCall, pointerProc, &*targetProc,
+                          specificIntrinsic, whyNot, warning)};
+                  if (!msg && warning &&
+                      semanticsContext.ShouldWarn(
+                          common::UsageWarning::ProcDummyArgShapes)) {
+                    msg =
+                        "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
+                    whyNot = std::move(*warning);
+                  }
+                  if (msg) {
                     msg->set_severity(parser::Severity::Warning);
                     messages.Say(std::move(*msg),
                         "pointer '" + pointerExpr->AsFortran() + "'",