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

[klausler]

Summary

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

[tskeith]

flang/lib/Semantics/pointer-assignment.cpp

174

The first comment terminator is messed up.

[klausler]

Patch bug found by reviewer.

flang/include/flang/Evaluate/characteristics.h

TypeAndShape &set_LEN(Expr<SubscriptInteger> &&len) {
     return *this;
   }
   const Shape &shape() const { return shape_; }
   const Attrs &attrs() const { return attrs_; }
   int corank() const { return corank_; }
 
   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;
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   static std::optional<TypeAndShape> Characterize(
       const semantics::AssocEntityDetails &, FoldingContext &);

flang/include/flang/Evaluate/shape.h

std::optional<ConstantSubscripts> GetConstantExtents(
   }
 }
 
 // Compilation-time shape conformance checking, when corresponding extents
 // are known.
 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
 // return false otherwise (including the case where one or more of the
 // extents are zero).
 bool IncrementSubscripts(
     ConstantSubscripts &, const ConstantSubscripts &extents);
 
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_SHAPE_H_

flang/lib/Evaluate/characteristics.cpp

 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const ActualArgument &arg, FoldingContext &context) {
   return Characterize(arg.UnwrapExpr(), context);
 }
 
 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(
         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
         thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs,
         type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""));
     return false;
   }
   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(
     FoldingContext *foldingContext) const {
   if (type_.category() == TypeCategory::Character && LEN_) {
     Expr<SubscriptInteger> result{
         common::Clone(*LEN_) * Expr<SubscriptInteger>{type_.kind()}};
     if (foldingContext) {

flang/lib/Evaluate/shape.cpp

auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
   }
   return std::nullopt;
 }
 
 // Check conformance of the passed shapes.  Only return true if we can verify
 // 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;
   }
   int rn{GetRank(right)};
   if (rn == 0 && rightScalarExpandable) {
     return true;
   }
   if (n != rn) {
     messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
         leftIs, n, rightIs, rn);
     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 (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;
+    }
   }
   return true;
 }
 
 bool IncrementSubscripts(
     ConstantSubscripts &indices, const ConstantSubscripts &extents) {
   std::size_t rank(indices.size());
   CHECK(rank <= extents.size());

flang/lib/Semantics/pointer-assignment.cpp

msg = "%s is associated with the result of a reference to function '%s'"
           " that is a not a pointer"_err_en_US;
   } else if (isContiguous_ &&
       !funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
     msg = "CONTIGUOUS %s is associated with the result of reference to"
           " function '%s' that is not contiguous"_err_en_US;
   } 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;
     }
   }
   if (msg) {
     auto restorer{common::ScopedSet(lhs_, symbol)};
     Say(*msg, description_, funcName);
     return false;

flang/test/Semantics/null01.f90

subroutine test
   !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
   ip0 => null(mold=1)
   !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
   ip0 => null(mold=j)
   dt0x = dt0(null())
   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())
   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
   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
   dt3x = dt3(pps1=null(mold=dt2x%pps0))
   dt3x = dt3(pps1=null(mold=dt3x%pps1))
 end subroutine test