summaryrefslogtreecommitdiff
path: root/flang
diff options
context:
space:
mode:
Diffstat (limited to 'flang')
-rw-r--r--flang/include/flang/Evaluate/characteristics.h5
-rw-r--r--flang/include/flang/Evaluate/shape.h3
-rw-r--r--flang/lib/Evaluate/characteristics.cpp6
-rw-r--r--flang/lib/Evaluate/shape.cpp24
-rw-r--r--flang/lib/Semantics/pointer-assignment.cpp4
-rw-r--r--flang/test/Semantics/null01.f904
6 files changed, 28 insertions, 18 deletions
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index bd0e1bf8186e..5d140a642c86 100644
--- 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 dc76afe57b40..da0b958a3beb 100644
--- 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 f88e518b4891..7b7e62ee179e 100644
--- 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 37373ae95692..b740c81e0796 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 dc5611cb257b..8cf46f5a5cda 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<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 a034d1b7b3df..0cfea52bcd3e 100644
--- 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())
View Lorry Controller Status