diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -298,6 +298,9 @@ return std::nullopt; } } +std::optional ExtractDataRef( + const ActualArgument &, bool intoSubstring = false); + std::optional ExtractSubstringBase(const Substring &); // Predicate: is an expression is an array element reference? diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -179,10 +179,6 @@ const auto *details{symbol.detailsIf()}; return details && details->IsAssumedSize(); } -inline bool IsAssumedRankArray(const Symbol &symbol) { - const auto *details{symbol.detailsIf()}; - return details && details->IsAssumedRank(); -} bool IsAssumedLengthCharacter(const Symbol &); bool IsExternal(const Symbol &); bool IsModuleProcedure(const Symbol &); diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -612,7 +612,7 @@ if (const auto *array{UnwrapExpr>(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(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(std::move(funcRef)); + } else if (auto &extent{shape->at(*dim - 1)}) { return Fold(context, ConvertToType(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{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/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/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -260,7 +260,15 @@ } } else if (const auto *assoc{ symbol.detailsIf()}) { - 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()}) { + 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(shape->size())) { + return std::move(shape->at(dimension)); + } + } + } if (const auto *details{symbol.detailsIf()}) { if (IsImpliedShape(symbol) && details->init()) { if (auto shape{GetShape(symbol)}) { @@ -369,13 +390,6 @@ } } } - } else if (const auto *assoc{ - symbol.detailsIf()}) { - if (auto shape{GetShape(assoc->expr())}) { - if (dimension < static_cast(shape->size())) { - return std::move(shape->at(dimension)); - } - } } return std::nullopt; } diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -50,6 +50,15 @@ std::move(expr.u)); } +std::optional ExtractDataRef( + const ActualArgument &arg, bool intoSubstring) { + if (const Expr *expr{arg.UnwrapExpr()}) { + return ExtractDataRef(*expr, intoSubstring); + } else { + return std::nullopt; + } +} + std::optional ExtractSubstringBase(const Substring &substring) { return std::visit( common::visitors{ @@ -665,6 +674,11 @@ } bool IsAssumedRank(const Symbol &original) { + if (const auto *assoc{original.detailsIf()}) { + if (assoc->rank()) { + return false; // in SELECT RANK case + } + } const Symbol &symbol{semantics::ResolveAssociations(original)}; if (const auto *details{symbol.detailsIf()}) { return details->IsAssumedRank(); diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/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/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp --- a/flang/lib/Semantics/check-select-rank.cpp +++ b/flang/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/flang/test/Semantics/select-rank.f90 b/flang/test/Semantics/select-rank.f90 --- a/flang/test/Semantics/select-rank.f90 +++ b/flang/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