[flang-commits] [flang] 4fed595 - [flang] Correct semantic representation & handling of RANK(*) (#66234)
via flang-commits
flang-commits at lists.llvm.org
Wed Sep 13 16:13:35 PDT 2023
Author: Peter Klausler
Date: 2023-09-13T16:13:31-07:00
New Revision: 4fed5959974e4a85504667ce47ef03234dd9aec6
URL: https://github.com/llvm/llvm-project/commit/4fed5959974e4a85504667ce47ef03234dd9aec6
DIFF: https://github.com/llvm/llvm-project/commit/4fed5959974e4a85504667ce47ef03234dd9aec6.diff
LOG: [flang] Correct semantic representation & handling of RANK(*) (#66234)
A RANK(*) case in a SELECT RANK construct selects the case of an
assumed-rank dummy argument whose effective actual argument is an
assumed-size array. In this case, the attributes of the selector are
those of a rank-1 assumed-size array, and the selector cannot be
allocatable or a pointer.
Ensure that the representation of a SELECT RANK construct's per-case
AssocEntityDetails can distinguish RANK(n), RANK(*), and RANK DEFAULT,
and clean up various code sites and tests where the distinctions matter.
Added:
Modified:
flang/include/flang/Evaluate/tools.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/shape.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-allocate.cpp
flang/lib/Semantics/check-select-rank.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
flang/test/Semantics/misc-intrinsics.f90
flang/test/Semantics/select-rank.f90
flang/test/Semantics/select-rank03.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index b3f8f4a67a7b5dd..71fe1237efdde7c 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1224,10 +1224,11 @@ bool IsEventTypeOrLockType(const DerivedTypeSpec *);
// of the construct entity.
// (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
// while GetAssociationRoot(x) returns y.)
-// ResolveAssociationsExceptSelectRank() stops at a RANK case symbol.
+// In a SELECT RANK construct, ResolveAssociations() stops at a
+// RANK(n) or RANK(*) case symbol, but traverses the selector for
+// RANK DEFAULT.
const Symbol &ResolveAssociations(const Symbol &);
const Symbol &GetAssociationRoot(const Symbol &);
-const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &);
const Symbol *FindCommonBlockContaining(const Symbol &);
int CountLenParameters(const DerivedTypeSpec &);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index aada3bf94cc1213..a5f4ad76c26b784 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -278,12 +278,33 @@ class AssocEntityDetails : public EntityDetails {
AssocEntityDetails &operator=(const AssocEntityDetails &) = default;
AssocEntityDetails &operator=(AssocEntityDetails &&) = default;
const MaybeExpr &expr() const { return expr_; }
+
+ // SELECT RANK's rank cases will return a populated result for
+ // RANK(n) and RANK(*), and IsAssumedRank() will be true for
+ // RANK DEFAULT.
+ std::optional<int> rank() const {
+ int r{rank_.value_or(0)};
+ if (r == isAssumedSize) {
+ return 1; // RANK(*)
+ } else if (r == isAssumedRank) {
+ return std::nullopt; // RANK DEFAULT
+ } else {
+ return rank_;
+ }
+ }
+ bool IsAssumedSize() const { return rank_.value_or(0) == isAssumedSize; }
+ bool IsAssumedRank() const { return rank_.value_or(0) == isAssumedRank; }
void set_rank(int rank);
- std::optional<int> rank() const { return rank_; }
+ void set_IsAssumedSize();
+ void set_IsAssumedRank();
private:
MaybeExpr expr_;
- std::optional<int> rank_; // for SELECT RANK
+ // Populated for SELECT RANK with rank (n>=0) for RANK(n),
+ // isAssumedSize for RANK(*), or isAssumedRank for RANK DEFAULT.
+ static constexpr int isAssumedSize{-1}; // RANK(*)
+ static constexpr int isAssumedRank{-2}; // RANK DEFAULT
+ std::optional<int> rank_;
};
llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
@@ -862,12 +883,14 @@ class Symbol {
return iface ? iface->RankImpl(depth) : 0;
},
[](const AssocEntityDetails &aed) {
- if (const auto &expr{aed.expr()}) {
- if (auto assocRank{aed.rank()}) {
- return *assocRank;
- } else {
- return expr->Rank();
- }
+ if (auto assocRank{aed.rank()}) {
+ // RANK(n) & RANK(*)
+ return *assocRank;
+ } else if (aed.IsAssumedRank()) {
+ // RANK DEFAULT
+ return 0;
+ } else if (const auto &expr{aed.expr()}) {
+ return expr->Rank();
} else {
return 0;
}
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 5bcb96e6050fa08..12649da6adbe21a 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -179,8 +179,13 @@ const Symbol *IsFinalizable(const DerivedTypeSpec &,
const Symbol *HasImpureFinal(const Symbol &);
bool IsInBlankCommon(const Symbol &);
inline bool IsAssumedSizeArray(const Symbol &symbol) {
- const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
- return details && details->IsAssumedSize();
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ return object->IsAssumedSize();
+ } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
+ return assoc->IsAssumedSize();
+ } else {
+ return false;
+ }
}
bool IsAssumedLengthCharacter(const Symbol &);
bool IsExternal(const Symbol &);
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 8f4923ff96a94b0..e26479cc1f055fb 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -248,17 +248,17 @@ class GetLowerBoundHelper
Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {
const Symbol &symbol{symbol0.GetUltimate()};
- if (const auto *details{
+ if (const auto *object{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- int rank{details->shape().Rank()};
+ int rank{object->shape().Rank()};
if (dimension_ < rank) {
- const semantics::ShapeSpec &shapeSpec{details->shape()[dimension_]};
+ const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]};
if (shapeSpec.lbound().isExplicit()) {
if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
if constexpr (LBOUND_SEMANTICS) {
bool ok{false};
auto lbValue{ToInt64(*lbound)};
- if (dimension_ == rank - 1 && details->IsAssumedSize()) {
+ if (dimension_ == rank - 1 && object->IsAssumedSize()) {
// last dimension of assumed-size dummy array: don't worry
// about handling an empty dimension
ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
@@ -309,7 +309,10 @@ class GetLowerBoundHelper
}
} else if (const auto *assoc{
symbol.detailsIf<semantics::AssocEntityDetails>()}) {
- if (assoc->rank()) { // SELECT RANK case
+ if (assoc->IsAssumedSize()) { // RANK(*)
+ return Result{1};
+ } else if (assoc->IsAssumedRank()) { // RANK DEFAULT
+ } else if (assoc->rank()) { // RANK(n)
const Symbol &resolved{ResolveAssociations(symbol)};
if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
return ExtentExpr{DescriptorInquiry{std::move(base),
@@ -497,9 +500,11 @@ MaybeExtentExpr GetExtent(
const NamedEntity &base, int dimension, bool invariantOnly) {
CHECK(dimension >= 0);
const Symbol &last{base.GetLastSymbol()};
- const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)};
+ const Symbol &symbol{ResolveAssociations(last)};
if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
- if (assoc->rank()) { // SELECT RANK case
+ if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) { // RANK(*)/DEFAULT
+ return std::nullopt;
+ } else if (assoc->rank()) { // RANK(n)
if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
return ExtentExpr{DescriptorInquiry{
NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
@@ -595,8 +600,7 @@ MaybeExtentExpr ComputeUpperBound(
MaybeExtentExpr GetRawUpperBound(
const NamedEntity &base, int dimension, bool invariantOnly) {
- const Symbol &symbol{
- ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
+ const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int rank{details->shape().Rank()};
if (dimension < rank) {
@@ -612,7 +616,11 @@ MaybeExtentExpr GetRawUpperBound(
}
} else if (const auto *assoc{
symbol.detailsIf<semantics::AssocEntityDetails>()}) {
- if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
+ if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
+ return std::nullopt;
+ } else if (assoc->rank() && dimension >= *assoc->rank()) {
+ return std::nullopt;
+ } else if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
return ComputeUpperBound(
GetRawLowerBound(base, dimension), std::move(extent));
}
@@ -645,8 +653,7 @@ static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
static MaybeExtentExpr GetUBOUND(FoldingContext *context,
const NamedEntity &base, int dimension, bool invariantOnly) {
- const Symbol &symbol{
- ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
+ const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int rank{details->shape().Rank()};
if (dimension < rank) {
@@ -662,7 +669,9 @@ static MaybeExtentExpr GetUBOUND(FoldingContext *context,
}
} else if (const auto *assoc{
symbol.detailsIf<semantics::AssocEntityDetails>()}) {
- if (assoc->rank()) { // SELECT RANK case
+ if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
+ return std::nullopt;
+ } else if (assoc->rank()) { // RANK (n)
const Symbol &resolved{ResolveAssociations(symbol)};
if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
ExtentExpr lb{DescriptorInquiry{NamedEntity{base},
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index d2fa5c9b5f36be6..aadbc0804b342a7 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -702,15 +702,14 @@ std::optional<Expr<SomeType>> ConvertToType(
bool IsAssumedRank(const Symbol &original) {
if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
if (assoc->rank()) {
- return false; // in SELECT RANK case
+ return false; // in RANK(n) or RANK(*)
+ } else if (assoc->IsAssumedRank()) {
+ return true; // RANK DEFAULT
}
}
const Symbol &symbol{semantics::ResolveAssociations(original)};
- if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- return details->IsAssumedRank();
- } else {
- return false;
- }
+ const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+ return object && object->IsAssumedRank();
}
bool IsAssumedRank(const ActualArgument &arg) {
@@ -1209,17 +1208,7 @@ namespace Fortran::semantics {
const Symbol &ResolveAssociations(const Symbol &original) {
const Symbol &symbol{original.GetUltimate()};
if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
- if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
- return ResolveAssociations(*nested);
- }
- }
- return symbol;
-}
-
-const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &original) {
- const Symbol &symbol{original.GetUltimate()};
- if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
- if (!details->rank()) {
+ if (!details->rank()) { // Not RANK(n) or RANK(*)
if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
return ResolveAssociations(*nested);
}
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 12d795290d927ad..2edb8e59fd08406 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -39,16 +39,11 @@ class AllocationCheckerHelper {
public:
AllocationCheckerHelper(
const parser::Allocation &alloc, AllocateCheckerInfo &info)
- : allocateInfo_{info},
- allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
- name_{parser::GetLastName(allocateObject_)},
- original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
- symbol_{original_ ? &ResolveAssociations(*original_) : nullptr},
- type_{symbol_ ? symbol_->GetType() : nullptr},
- allocateShapeSpecRank_{ShapeSpecRank(alloc)},
- rank_{original_ ? original_->Rank() : 0},
- allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
- corank_{symbol_ ? symbol_->Corank() : 0} {}
+ : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
+ alloc.t)},
+ allocateShapeSpecRank_{ShapeSpecRank(alloc)}, allocateCoarraySpecRank_{
+ CoarraySpecRank(
+ alloc)} {}
bool RunChecks(SemanticsContext &context);
@@ -90,14 +85,17 @@ class AllocationCheckerHelper {
AllocateCheckerInfo &allocateInfo_;
const parser::AllocateObject &allocateObject_;
- const parser::Name &name_;
- const Symbol *original_{nullptr}; // no USE or host association
- const Symbol *symbol_{nullptr}; // no USE, host, or construct association
- const DeclTypeSpec *type_{nullptr};
- const int allocateShapeSpecRank_;
- const int rank_{0};
- const int allocateCoarraySpecRank_;
- const int corank_{0};
+ const int allocateShapeSpecRank_{0};
+ const int allocateCoarraySpecRank_{0};
+ const parser::Name &name_{parser::GetLastName(allocateObject_)};
+ // no USE or host association
+ const Symbol *original_{
+ name_.symbol ? &name_.symbol->GetUltimate() : nullptr};
+ // no USE, host, or construct association
+ const Symbol *symbol_{original_ ? &ResolveAssociations(*original_) : nullptr};
+ const DeclTypeSpec *type_{symbol_ ? symbol_->GetType() : nullptr};
+ const int rank_{original_ ? original_->Rank() : 0};
+ const int corank_{symbol_ ? symbol_->Corank() : 0};
bool hasDeferredTypeParameter_{false};
bool isUnlimitedPolymorphic_{false};
bool isAbstract_{false};
@@ -539,6 +537,11 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
}
}
// Shape related checks
+ if (symbol_ && evaluate::IsAssumedRank(*symbol_)) {
+ context.Say(name_.source,
+ "An assumed-rank object may not appear in an ALLOCATE statement"_err_en_US);
+ return false;
+ }
if (rank_ > 0) {
if (!hasAllocateShapeSpecList()) {
// C939
diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp
index 424f9b45d64cdfd..2e602d307013c1e 100644
--- a/flang/lib/Semantics/check-select-rank.cpp
+++ b/flang/lib/Semantics/check-select-rank.cpp
@@ -87,7 +87,7 @@ void SelectRankConstructChecker::Leave(
}
if (saveSelSymbol &&
IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
- context_.Say(parser::FindSourceLocation(selectRankStmtSel),
+ context_.Say(rankCaseStmt.source,
"RANK (*) cannot be used when selector is "
"POINTER or ALLOCATABLE"_err_en_US);
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index d690f3da6820dbb..4ccb2c3ef5d0121 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -260,11 +260,11 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
symbolRank, symbol.name(), subscripts);
}
return std::nullopt;
- } else if (const auto *object{
- symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+ } else if (symbol.has<semantics::ObjectEntityDetails>() ||
+ symbol.has<semantics::AssocEntityDetails>()) {
// C928 & C1002
if (Triplet *last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
- if (!last->upper() && object->IsAssumedSize()) {
+ if (!last->upper() && IsAssumedSizeArray(symbol)) {
Say("Assumed-size array '%s' must have explicit final "
"subscript upper bound value"_err_en_US,
symbol.name());
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 29cd107186fb5f0..126c035ef57fabe 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6942,17 +6942,32 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
if (auto *symbol{MakeAssocEntity()}) {
SetTypeFromAssociation(*symbol);
+ auto &details{symbol->get<AssocEntityDetails>()};
// Don't call SetAttrsFromAssociation() for SELECT RANK.
- symbol->attrs() |=
- evaluate::GetAttrs(GetCurrentAssociation().selector.expr) &
- Attrs{Attr::ALLOCATABLE, Attr::ASYNCHRONOUS, Attr::POINTER,
- Attr::TARGET, Attr::VOLATILE};
- if (const auto *init{std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
- if (auto val{EvaluateInt64(context(), *init)}) {
- auto &details{symbol->get<AssocEntityDetails>()};
- details.set_rank(*val);
+ Attrs selectorAttrs{
+ evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
+ Attrs attrsToKeep{Attr::ASYNCHRONOUS, Attr::TARGET, Attr::VOLATILE};
+ if (const auto *rankValue{
+ std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
+ // RANK(n)
+ if (auto expr{EvaluateIntExpr(*rankValue)}) {
+ if (auto val{evaluate::ToInt64(*expr)}) {
+ details.set_rank(*val);
+ attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
+ } else {
+ Say("RANK() expression must be constant"_err_en_US);
+ }
}
+ } else if (std::holds_alternative<parser::Star>(x.u)) {
+ // RANK(*): assumed-size
+ details.set_IsAssumedSize();
+ } else {
+ CHECK(std::holds_alternative<parser::Default>(x.u));
+ // RANK DEFAULT: assumed-rank
+ details.set_IsAssumedRank();
+ attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
}
+ symbol->attrs() |= selectorAttrs & attrsToKeep;
}
}
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 2e14b2e8a19559c..f4edc8a08fe699d 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -153,6 +153,8 @@ void EntityDetails::set_type(const DeclTypeSpec &type) {
}
void AssocEntityDetails::set_rank(int rank) { rank_ = rank; }
+void AssocEntityDetails::set_IsAssumedSize() { rank_ = isAssumedSize; }
+void AssocEntityDetails::set_IsAssumedRank() { rank_ = isAssumedRank; }
void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
@@ -438,8 +440,12 @@ llvm::raw_ostream &operator<<(
llvm::raw_ostream &operator<<(
llvm::raw_ostream &os, const AssocEntityDetails &x) {
os << *static_cast<const EntityDetails *>(&x);
- if (auto assocRank{x.rank()}) {
- os << " rank: " << *assocRank;
+ if (x.IsAssumedSize()) {
+ os << " RANK(*)";
+ } else if (x.IsAssumedRank()) {
+ os << " RANK DEFAULT";
+ } else if (auto assocRank{x.rank()}) {
+ os << " RANK(" << *assocRank << ')';
}
DumpExpr(os, "expr", x.expr());
return os;
diff --git a/flang/test/Semantics/misc-intrinsics.f90 b/flang/test/Semantics/misc-intrinsics.f90
index c8f6529970ca0fc..195906eef9d79e5 100644
--- a/flang/test/Semantics/misc-intrinsics.f90
+++ b/flang/test/Semantics/misc-intrinsics.f90
@@ -42,6 +42,25 @@ subroutine test(arg, assumedRank)
print *, lbound(assumedRank, dim=2)
!ERROR: DIM=2 dimension is out of range for rank-1 array
print *, ubound(assumedRank, dim=2)
+ rank(*)
+ !ERROR: A dim= argument is required for 'size' when the array is assumed-size
+ print *, size(assumedRank)
+ !ERROR: missing mandatory 'dim=' argument
+ print *, ubound(assumedRank)
+ !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
+ print *, shape(assumedRank)
+ !ERROR: The 'harvest=' argument to the intrinsic procedure 'random_number' may not be assumed-size
+ call random_number(assumedRank)
+ !ERROR: DIM=0 dimension must be positive
+ print *, lbound(assumedRank, 0)
+ !ERROR: DIM=0 dimension must be positive
+ print *, ubound(assumedRank, 0)
+ !ERROR: DIM=1 dimension is out of range for rank-1 assumed-size array
+ print *, ubound(assumedRank, 1)
+ !ERROR: DIM=2 dimension is out of range for rank-1 array
+ print *, lbound(assumedRank, dim=2)
+ !ERROR: DIM=2 dimension is out of range for rank-1 array
+ print *, ubound(assumedRank, dim=2)
end select
! But these cases are fine:
print *, size(arg, dim=1)
@@ -60,6 +79,8 @@ subroutine test(arg, assumedRank)
rank(3)
print *, lbound(assumedRank, dim=2)
print *, ubound(assumedRank, dim=2)
+ rank(*)
+ print *, lbound(assumedRank, dim=1)
rank default
print *, lbound(assumedRank, dim=2)
print *, ubound(assumedRank, dim=2)
diff --git a/flang/test/Semantics/select-rank.f90 b/flang/test/Semantics/select-rank.f90
index 0dc915a99914ac3..fa8d2fc4d461dfc 100644
--- a/flang/test/Semantics/select-rank.f90
+++ b/flang/test/Semantics/select-rank.f90
@@ -109,7 +109,8 @@ subroutine CALL_ME6(x)
j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3))
!ERROR: The value of the selector must be between zero and 15
RANK(-1)
- print *, "rank: -ve"
+ print *, "rank: negative"
+ !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
@@ -119,8 +120,8 @@ subroutine CALL_ME7(arg)
integer :: i,j
integer, dimension(..), pointer :: arg
integer, pointer :: arg2
- !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
select RANK(arg)
+ !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
RANK (*)
print *, arg(1:1)
RANK (1)
@@ -146,13 +147,10 @@ subroutine CALL_ME8(x)
print *, "Now it's rank 2 "
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
diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90
index 038380435d00d7c..f49767c5adf3323 100644
--- a/flang/test/Semantics/select-rank03.f90
+++ b/flang/test/Semantics/select-rank03.f90
@@ -6,7 +6,6 @@ program test
contains
subroutine allocatables(a)
real, allocatable :: a(..)
- !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
select rank(a)
rank (0)
allocate(a) ! ok
@@ -44,13 +43,17 @@ subroutine allocatables(a)
allocate(a, source=a1)
!ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
allocate(a, mold=p1)
+ !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
rank (*)
- !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ !ERROR: Whole assumed-size array 'a' may not appear here without subscripts
+ !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
allocate(a)
+ !ERROR: Whole assumed-size array 'a' may not appear here without subscripts
deallocate(a)
+ !ERROR: Whole assumed-size array 'a' may not appear here without subscripts
a = 1.
rank default
- !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ !ERROR: An assumed-rank object may not appear in an ALLOCATE statement
allocate(a)
deallocate(a)
a = 1.
@@ -58,7 +61,6 @@ subroutine allocatables(a)
end
subroutine pointers(p)
real, pointer :: p(..)
- !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
select rank(p)
rank (0)
allocate(p) ! ok
@@ -98,12 +100,15 @@ subroutine pointers(p)
p => t0
!ERROR: Pointer has rank 2 but target has rank 1
p => t1
+ !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
rank (*)
- !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ !ERROR: Whole assumed-size array 'p' may not appear here without subscripts
+ !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
allocate(p)
+ !ERROR: Whole assumed-size array 'p' may not appear here without subscripts
deallocate(p)
rank default
- !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ !ERROR: An assumed-rank object may not appear in an ALLOCATE statement
allocate(p)
deallocate(p)
!ERROR: pointer 'p' associated with object 't0' with incompatible type or shape
More information about the flang-commits
mailing list