[flang] Validate SIZE(x,DIM=n) dimension for assumed-size array x
Catch invalid attempts to extract the unknowable extent of the last
dimension of an assumed-size array dummy argument, and clean up
problems with assumed-rank arguments in similar circumstances
exposed by testing the fix.
Differential Revision: https://reviews.llvm.org/D109918
GitOrigin-RevId: 9245f35580ca0cce147ec9cebfa431fa5b7feac4
diff --git a/include/flang/Evaluate/tools.h b/include/flang/Evaluate/tools.h
index 50a9e26..5ebf3cd 100644
--- a/include/flang/Evaluate/tools.h
+++ b/include/flang/Evaluate/tools.h
@@ -298,6 +298,9 @@
return std::nullopt;
}
}
+std::optional<DataRef> ExtractDataRef(
+ const ActualArgument &, bool intoSubstring = false);
+
std::optional<DataRef> ExtractSubstringBase(const Substring &);
// Predicate: is an expression is an array element reference?
diff --git a/include/flang/Semantics/tools.h b/include/flang/Semantics/tools.h
index d969dc9..5c23bc3 100644
--- a/include/flang/Semantics/tools.h
+++ b/include/flang/Semantics/tools.h
@@ -179,10 +179,6 @@
const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
return details && details->IsAssumedSize();
}
-inline bool IsAssumedRankArray(const Symbol &symbol) {
- const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
- return details && details->IsAssumedRank();
-}
bool IsAssumedLengthCharacter(const Symbol &);
bool IsExternal(const Symbol &);
bool IsModuleProcedure(const Symbol &);
diff --git a/lib/Evaluate/fold-integer.cpp b/lib/Evaluate/fold-integer.cpp
index 3fdf252..c69ce32 100644
--- a/lib/Evaluate/fold-integer.cpp
+++ b/lib/Evaluate/fold-integer.cpp
@@ -612,7 +612,7 @@
if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
if (auto named{ExtractNamedEntity(*array)}) {
const Symbol &symbol{named->GetLastSymbol()};
- if (semantics::IsAssumedRankArray(symbol)) {
+ if (IsAssumedRank(symbol)) {
// DescriptorInquiry can only be placed in expression of kind
// DescriptorInquiry::Result::kind.
return ConvertToType<T>(Expr<
@@ -667,7 +667,13 @@
if (auto dim{GetInt64Arg(args[1])}) {
int rank{GetRank(*shape)};
if (*dim >= 1 && *dim <= rank) {
- if (auto &extent{shape->at(*dim - 1)}) {
+ const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])};
+ if (symbol && IsAssumedSizeArray(*symbol) && *dim == rank) {
+ context.messages().Say(
+ "size(array,dim=%jd) of last dimension is not available for rank-%d assumed-size array dummy argument"_err_en_US,
+ *dim, rank);
+ return MakeInvalidIntrinsic<T>(std::move(funcRef));
+ } else if (auto &extent{shape->at(*dim - 1)}) {
return Fold(context, ConvertToType<T>(std::move(*extent)));
}
} else {
@@ -705,7 +711,7 @@
} else if (name == "ubound") {
return UBOUND(context, std::move(funcRef));
}
- // TODO: count(w/ dim), dot_product, findloc, ibits, image_status, ishftc,
+ // TODO: dot_product, findloc, ibits, image_status, ishftc,
// matmul, maxloc, minloc, sign, transfer
return Expr<T>{std::move(funcRef)};
}
diff --git a/lib/Evaluate/formatting.cpp b/lib/Evaluate/formatting.cpp
index 5b5ae25..2569c85 100644
--- a/lib/Evaluate/formatting.cpp
+++ b/lib/Evaluate/formatting.cpp
@@ -739,7 +739,7 @@
if (field_ == Field::Len) {
return o << "%len";
} else {
- if (dimension_ >= 0) {
+ if (field_ != Field::Rank && dimension_ >= 0) {
o << ",dim=" << (dimension_ + 1);
}
return o << ')';
diff --git a/lib/Evaluate/shape.cpp b/lib/Evaluate/shape.cpp
index 8919038..0d2bb50 100644
--- a/lib/Evaluate/shape.cpp
+++ b/lib/Evaluate/shape.cpp
@@ -260,7 +260,15 @@
}
} else if (const auto *assoc{
symbol.detailsIf<semantics::AssocEntityDetails>()}) {
- return (*this)(assoc->expr());
+ if (assoc->rank()) { // SELECT RANK case
+ const Symbol &resolved{ResolveAssociations(symbol)};
+ if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
+ return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
+ DescriptorInquiry::Field::LowerBound, dimension_}};
+ }
+ } else {
+ return (*this)(assoc->expr());
+ }
}
return Default();
}
@@ -338,7 +346,20 @@
MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
CHECK(dimension >= 0);
- const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
+ const Symbol &last{base.GetLastSymbol()};
+ const Symbol &symbol{ResolveAssociations(last)};
+ if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
+ if (assoc->rank()) { // SELECT RANK case
+ if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
+ return ExtentExpr{DescriptorInquiry{
+ NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
+ }
+ } else if (auto shape{GetShape(assoc->expr())}) {
+ if (dimension < static_cast<int>(shape->size())) {
+ return std::move(shape->at(dimension));
+ }
+ }
+ }
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
if (IsImpliedShape(symbol) && details->init()) {
if (auto shape{GetShape(symbol)}) {
@@ -369,13 +390,6 @@
}
}
}
- } else if (const auto *assoc{
- symbol.detailsIf<semantics::AssocEntityDetails>()}) {
- if (auto shape{GetShape(assoc->expr())}) {
- if (dimension < static_cast<int>(shape->size())) {
- return std::move(shape->at(dimension));
- }
- }
}
return std::nullopt;
}
diff --git a/lib/Evaluate/tools.cpp b/lib/Evaluate/tools.cpp
index fde6089..dd66259 100644
--- a/lib/Evaluate/tools.cpp
+++ b/lib/Evaluate/tools.cpp
@@ -50,6 +50,15 @@
std::move(expr.u));
}
+std::optional<DataRef> ExtractDataRef(
+ const ActualArgument &arg, bool intoSubstring) {
+ if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) {
+ return ExtractDataRef(*expr, intoSubstring);
+ } else {
+ return std::nullopt;
+ }
+}
+
std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
return std::visit(
common::visitors{
@@ -665,6 +674,11 @@
}
bool IsAssumedRank(const Symbol &original) {
+ if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
+ if (assoc->rank()) {
+ return false; // in SELECT RANK case
+ }
+ }
const Symbol &symbol{semantics::ResolveAssociations(original)};
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
return details->IsAssumedRank();
diff --git a/lib/Evaluate/variable.cpp b/lib/Evaluate/variable.cpp
index 6b5f4ca..6a9fced 100644
--- a/lib/Evaluate/variable.cpp
+++ b/lib/Evaluate/variable.cpp
@@ -245,7 +245,7 @@
: base_{base}, field_{field}, dimension_{dim} {
const Symbol &last{base_.GetLastSymbol()};
CHECK(IsDescriptor(last));
- CHECK((field == Field::Len && dim == 0) ||
+ CHECK(((field == Field::Len || field == Field::Rank) && dim == 0) ||
(field != Field::Len && dim >= 0 && dim < last.Rank()));
}
diff --git a/lib/Semantics/check-select-rank.cpp b/lib/Semantics/check-select-rank.cpp
index 3487fb5..595c17f 100644
--- a/lib/Semantics/check-select-rank.cpp
+++ b/lib/Semantics/check-select-rank.cpp
@@ -32,7 +32,7 @@
const Symbol *saveSelSymbol{nullptr};
if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {
if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {
- if (!IsAssumedRankArray(*sel)) { // C1150
+ if (!evaluate::IsAssumedRank(*sel)) { // C1150
context_.Say(parser::FindSourceLocation(selectRankStmtSel),
"Selector '%s' is not an assumed-rank array variable"_err_en_US,
sel->name().ToString());
diff --git a/test/Semantics/select-rank.f90 b/test/Semantics/select-rank.f90
index d0cd931..3e21e48 100644
--- a/test/Semantics/select-rank.f90
+++ b/test/Semantics/select-rank.f90
@@ -145,11 +145,13 @@
Rank(2)
print *, "Now it's rank 2 "
RANK (*)
- print *, "Going for a other rank"
+ print *, "Going for another rank"
+ !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
!ERROR: Not more than one of the selectors of SELECT RANK statement may be '*'
RANK (*)
print *, "This is Wrong"
+ !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
END SELECT
end subroutine
