diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index bd0e1bf8186efe5..5d140a642c86a9b 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -145,8 +145,9 @@ class TypeAndShape { 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> MeasureSizeInBytes( FoldingContext * = nullptr) const; diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index dc76afe57b40f34..da0b958a3beb23d 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -211,7 +211,8 @@ std::optional 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 f88e518b4891e19..7b7e62ee179e3b6 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -150,7 +150,8 @@ std::optional 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> TypeAndShape::MeasureSizeInBytes( diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 37373ae956921e8..b740c81e07965c1 100644 --- 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 dc5611cb257b7e2..8cf46f5a5cda7de 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -169,7 +169,9 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef &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 a034d1b7b3dfab6..0cfea52bcd3e2a9 100644 --- a/flang/test/Semantics/null01.f90 +++ b/flang/test/Semantics/null01.f90 @@ -61,10 +61,10 @@ function f3() 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())