[flang] Improve procedure interface compatibility checking for dummy … (#72704)

…arrays

When comparing dummy array extents, cope with references to symbols
better (including references to other dummy arguments), and emit
warnings in dubious cases that are not equivalent but not provably
incompatible.

Author: klausler

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

@@ -1089,11 +1089,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 {
@@ -1185,6 +1186,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 {
@@ -1261,6 +1268,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

@@ -971,7 +971,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(
@@ -988,6 +990,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()) {
@@ -1351,16 +1358,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() + "'",