[flang] Tune warning about incompatible implicit interfaces

The compiler was emitting a warning about incompatible shapes
being used for two calls to the same procedure with an implicit
interface when one passed a whole array and the other passed
a scalar.  When the scalar is a whole element of a contiguous
array, however, we must allow for storage association and not flag
it as being a problem.

Author: klausler

flang/include/flang/Evaluate/characteristics.h

@@ -174,6 +174,14 @@ class TypeAndShape {
   }
   const std::optional<Shape> &shape() const { return shape_; }
   const Attrs &attrs() const { return attrs_; }
+  Attrs &attrs() { return attrs_; }
+  bool isPossibleSequenceAssociation() const {
+    return isPossibleSequenceAssociation_;
+  }
+  TypeAndShape &set_isPossibleSequenceAssociation(bool yes) {
+    isPossibleSequenceAssociation_ = yes;
+    return *this;
+  }
   int corank() const { return corank_; }
   void set_corank(int n) { corank_ = n; }
 
@@ -209,11 +217,11 @@ class TypeAndShape {
   void AcquireLEN();
   void AcquireLEN(const semantics::Symbol &);
 
-protected:
   DynamicType type_;
   std::optional<Expr<SubscriptInteger>> LEN_;
   std::optional<Shape> shape_;
   Attrs attrs_;
+  bool isPossibleSequenceAssociation_{false};
   int corank_{0};
 };
 

flang/include/flang/Evaluate/tools.h

@@ -396,20 +396,22 @@ std::optional<DataRef> ExtractDataRef(const ActualArgument &,
 
 // Predicate: is an expression is an array element reference?
 template <typename T>
-bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = true,
+const Symbol *IsArrayElement(const Expr<T> &expr, bool intoSubstring = true,
     bool skipComponents = false) {
   if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
     for (const DataRef *ref{&*dataRef}; ref;) {
       if (const Component * component{std::get_if<Component>(&ref->u)}) {
         ref = skipComponents ? &component->base() : nullptr;
       } else if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
         ref = &coarrayRef->base();
+      } else if (const auto *arrayRef{std::get_if<ArrayRef>(&ref->u)}) {
+        return &arrayRef->GetLastSymbol();
       } else {
-        return std::holds_alternative<ArrayRef>(ref->u);
+        break;
       }
     }
   }
-  return false;
+  return nullptr;
 }
 
 template <typename A>

flang/lib/Evaluate/characteristics.cpp

@@ -274,6 +274,9 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
     }
     o << ')';
   }
+  if (isPossibleSequenceAssociation_) {
+    o << " isPossibleSequenceAssociation";
+  }
   return o;
 }
 
@@ -282,17 +285,26 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
       coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
 }
 
+static bool IsOkWithSequenceAssociation(
+    const TypeAndShape &t1, const TypeAndShape &t2) {
+  return t1.isPossibleSequenceAssociation() &&
+      (t2.isPossibleSequenceAssociation() || t2.CanBeSequenceAssociated());
+}
+
 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";
+  if (!IsOkWithSequenceAssociation(type, actual.type) &&
+      !IsOkWithSequenceAssociation(actual.type, type)) {
+    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";
     }
-    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
@@ -343,10 +355,29 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
       }
     }
   }
-  if (!IdenticalSignificantAttrs(attrs, actual.attrs) ||
+  if (!attrs.test(Attr::DeducedFromActual) &&
+      !actual.attrs.test(Attr::DeducedFromActual) &&
       type.attrs() != actual.type.attrs()) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object shape attributes";
+      auto differences{type.attrs() ^ actual.type.attrs()};
+      auto sep{": "s};
+      differences.IterateOverMembers([&](TypeAndShape::Attr x) {
+        *whyNot += sep + std::string{TypeAndShape::EnumToString(x)};
+        sep = ", ";
+      });
+    }
+    return false;
+  }
+  if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object attributes";
+      auto differences{attrs ^ actual.attrs};
+      auto sep{": "s};
+      differences.IterateOverMembers([&](DummyDataObject::Attr x) {
+        *whyNot += sep + std::string{EnumToString(x)};
+        sep = ", ";
+      });
     }
     return false;
   }
@@ -900,6 +931,15 @@ std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
                 type->set_type(DynamicType{
                     type->type().GetDerivedTypeSpec(), /*poly=*/false});
               }
+              if (type->type().category() == TypeCategory::Character &&
+                  type->type().kind() == 1) {
+                type->set_isPossibleSequenceAssociation(true);
+              } else if (const Symbol * array{IsArrayElement(expr)}) {
+                type->set_isPossibleSequenceAssociation(
+                    IsContiguous(*array, context).value_or(false));
+              } else {
+                type->set_isPossibleSequenceAssociation(expr.Rank() > 0);
+              }
               DummyDataObject obj{std::move(*type)};
               obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
               return std::make_optional<DummyArgument>(

flang/lib/Semantics/check-call.cpp

@@ -561,7 +561,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
             dummyName);
       }
-      bool actualIsArrayElement{IsArrayElement(actual)};
+      bool actualIsArrayElement{IsArrayElement(actual) != nullptr};
       bool actualIsCKindCharacter{
           actualType.type().category() == TypeCategory::Character &&
           actualType.type().kind() == 1};

flang/test/Semantics/call43.f90

@@ -0,0 +1,17 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+subroutine from(a, b, c, d)
+  real a(10), b(:), c
+  real, contiguous :: d(:)
+  call to(a)
+  call to(a(1)) ! ok
+  call to(b) ! ok, passed via temp
+  !WARNING: Reference to the procedure 'to' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes
+  call to(b(1))
+  !WARNING: Reference to the procedure 'to' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes
+  call to(c)
+  !WARNING: Reference to the procedure 'to' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes
+  call to(1.)
+  call to([1., 2.]) ! ok
+  call to(d) ! ok
+  call to(d(1)) ! ok
+end