[flang] Fix false error message for "ptr => func()" array conformance

Pointers must have deferred shapes, so CheckConformance must be
extended to allow for them.

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

diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index bd0e1bf..5d140a6 100644 (file)
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -145,8 +145,9 @@ public:
 
   int Rank() const { return GetRank(shape_); }
   bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that,
-      const char *thisIs = "POINTER", const char *thatIs = "TARGET",
-      bool isElemental = false) const;
+      const char *thisIs = "pointer", const char *thatIs = "target",
+      bool isElemental = false, bool thisIsDeferredShape = false,
+      bool thatIsDeferredShape = false) const;
   std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(
       FoldingContext * = nullptr) const;
 

diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index dc76afe..da0b958 100644 (file)
--- a/flang/include/flang/Evaluate/shape.h
+++ b/flang/include/flang/Evaluate/shape.h
@@ -211,7 +211,8 @@ std::optional<ConstantSubscripts> GetConstantExtents(
 bool CheckConformance(parser::ContextualMessages &, const Shape &left,
     const Shape &right, const char *leftIs = "left operand",
     const char *rightIs = "right operand", bool leftScalarExpandable = true,
-    bool rightScalarExpandable = true);
+    bool rightScalarExpandable = true, bool leftIsDeferredShape = false,
+    bool rightIsDeferredShape = false);
 
 // Increments one-based subscripts in element order (first varies fastest)
 // and returns true when they remain in range; resets them all to one and

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index f88e518..7b7e62e 100644 (file)
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -150,7 +150,8 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,
-    bool isElemental) const {
+    bool isElemental, bool thisIsDeferredShape,
+    bool thatIsDeferredShape) const {
   if (!type_.IsTkCompatibleWith(that.type_)) {
     const auto &len{that.LEN()};
     messages.Say(
@@ -161,7 +162,8 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
   }
   return isElemental ||
       CheckConformance(messages, shape_, that.shape_, thisIs, thatIs, false,
-          false /* no scalar expansion */);
+          false /* no scalar expansion */, thisIsDeferredShape,
+          thatIsDeferredShape);
 }
 
 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(

diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 37373ae..b740c81 100644 (file)
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -683,7 +683,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
 // that they conform
 bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
     const Shape &right, const char *leftIs, const char *rightIs,
-    bool leftScalarExpandable, bool rightScalarExpandable) {
+    bool leftScalarExpandable, bool rightScalarExpandable,
+    bool leftIsDeferredShape, bool rightIsDeferredShape) {
   int n{GetRank(left)};
   if (n == 0 && leftScalarExpandable) {
     return true;
@@ -698,15 +699,18 @@ bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
     return false;
   }
   for (int j{0}; j < n; ++j) {
-    auto leftDim{ToInt64(left[j])};
-    auto rightDim{ToInt64(right[j])};
-    if (!leftDim || !rightDim) {
-      return false;
-    }
-    if (*leftDim != *rightDim) {
-      messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
-                   "but %4$s has extent %5$jd"_err_en_US,
-          j + 1, leftIs, *leftDim, rightIs, *rightDim);
+    if (auto leftDim{ToInt64(left[j])}) {
+      if (auto rightDim{ToInt64(right[j])}) {
+        if (*leftDim != *rightDim) {
+          messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
+                       "but %4$s has extent %5$jd"_err_en_US,
+              j + 1, leftIs, *leftDim, rightIs, *rightDim);
+          return false;
+        }
+      } else if (!rightIsDeferredShape) {
+        return false;
+      }
+    } else if (!leftIsDeferredShape) {
       return false;
     }
   }

diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index dc5611c..8cf46f5 100644 (file)
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -169,7 +169,9 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
   } else if (lhsType_) {
     const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
     CHECK(frTypeAndShape);
-    if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape)) {
+    if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape,
+            "pointer", "function result", false /*elemental*/,
+            true /*left: deferred shape*/, true /*right: deferred shape*/)) {
       msg = "%s is associated with the result of a reference to function '%s'"
             " whose pointer result has an incompatible type or shape"_err_en_US;
     }

diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90
index a034d1b..0cfea52 100644 (file)
--- a/flang/test/Semantics/null01.f90
+++ b/flang/test/Semantics/null01.f90
@@ -61,10 +61,10 @@ subroutine test
   dt0x = dt0(ip0=null())
   dt0x = dt0(ip0=null(ip0))
   dt0x = dt0(ip0=null(mold=ip0))
-  !ERROR: TARGET type 'REAL(4)' is not compatible with POINTER type 'INTEGER(4)'
+  !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)'
   !ERROR: pointer 'ip0' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape
   dt0x = dt0(ip0=null(mold=rp0))
-  !ERROR: TARGET type 'REAL(4)' is not compatible with POINTER type 'INTEGER(4)'
+  !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)'
   !ERROR: pointer 'ip1' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape
   dt1x = dt1(ip1=null(mold=rp1))
   dt2x = dt2(pps0=null())