diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index d5cdebd7e49f0..9d51649652537 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1475,8 +1475,16 @@ bool IsObjectPointer(const Symbol *original) { bool IsAllocatableOrObjectPointer(const Symbol *original) { if (original) { - const Symbol &symbol{GetAssociationRoot(*original)}; - return IsAllocatable(symbol) || (IsPointer(symbol) && !IsProcedure(symbol)); + const Symbol &ultimate{original->GetUltimate()}; + if (const auto *assoc{ultimate.detailsIf()}) { + // Only SELECT RANK construct entities can be ALLOCATABLE/POINTER. + return (assoc->rank() || assoc->IsAssumedSize() || + assoc->IsAssumedRank()) && + IsAllocatableOrObjectPointer(UnwrapWholeSymbolDataRef(assoc->expr())); + } else { + return IsAllocatable(ultimate) || + (IsPointer(ultimate) && !IsProcedure(ultimate)); + } } else { return false; } diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp index 2edb8e59fd084..ba1161b21f836 100644 --- a/flang/lib/Semantics/check-allocate.cpp +++ b/flang/lib/Semantics/check-allocate.cpp @@ -89,13 +89,11 @@ class AllocationCheckerHelper { const int allocateCoarraySpecRank_{0}; const parser::Name &name_{parser::GetLastName(allocateObject_)}; // no USE or host association - const Symbol *original_{ + const Symbol *ultimate_{ 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}; + const DeclTypeSpec *type_{ultimate_ ? ultimate_->GetType() : nullptr}; + const int rank_{ultimate_ ? ultimate_->Rank() : 0}; + const int corank_{ultimate_ ? ultimate_->Corank() : 0}; bool hasDeferredTypeParameter_{false}; bool isUnlimitedPolymorphic_{false}; bool isAbstract_{false}; @@ -448,11 +446,11 @@ static bool HaveCompatibleLengths( } bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { - if (!symbol_) { + if (!ultimate_) { CHECK(context.AnyFatalError()); return false; } - if (!IsVariableName(*symbol_)) { // C932 pre-requisite + if (!IsVariableName(*ultimate_)) { // C932 pre-requisite context.Say(name_.source, "Name in ALLOCATE statement must be a variable name"_err_en_US); return false; @@ -465,7 +463,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { return false; } GatherAllocationBasicInfo(); - if (!IsAllocatableOrPointer(*symbol_)) { // C932 + if (!IsAllocatableOrObjectPointer(ultimate_)) { // C932 context.Say(name_.source, "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); return false; @@ -537,11 +535,16 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { } } // Shape related checks - if (symbol_ && evaluate::IsAssumedRank(*symbol_)) { + if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) { context.Say(name_.source, "An assumed-rank object may not appear in an ALLOCATE statement"_err_en_US); return false; } + if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) { + // An assumed-size dummy array or RANK(*) case of SELECT RANK will have + // already been diagnosed; don't pile on. + return false; + } if (rank_ > 0) { if (!hasAllocateShapeSpecList()) { // C939 @@ -568,7 +571,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { .Say(name_.source, "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US) .Attach( - original_->name(), "Declared here with rank %d"_en_US, rank_); + ultimate_->name(), "Declared here with rank %d"_en_US, rank_); return false; } } @@ -587,7 +590,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { "If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US) .Attach(allocateInfo_.sourceExprLoc.value(), "SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank) - .Attach(symbol_->name(), + .Attach(ultimate_->name(), "Allocatable object declared here with rank %d"_en_US, rank_); return false; } @@ -611,11 +614,11 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { bool AllocationCheckerHelper::RunCoarrayRelatedChecks( SemanticsContext &context) const { - if (!symbol_) { + if (!ultimate_) { CHECK(context.AnyFatalError()); return false; } - if (evaluate::IsCoarray(*symbol_)) { + if (evaluate::IsCoarray(*ultimate_)) { if (allocateInfo_.gotTypeSpec) { // C938 if (const DerivedTypeSpec * @@ -665,8 +668,8 @@ bool AllocationCheckerHelper::RunCoarrayRelatedChecks( context .Say(name_.source, "Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US) - .Attach( - symbol_->name(), "Declared here with corank %d"_en_US, corank_); + .Attach(ultimate_->name(), "Declared here with corank %d"_en_US, + corank_); return false; } } diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90 index f49767c5adf33..234bd1a115493 100644 --- a/flang/test/Semantics/select-rank03.f90 +++ b/flang/test/Semantics/select-rank03.f90 @@ -46,7 +46,6 @@ subroutine allocatables(a) !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE rank (*) !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) @@ -58,6 +57,21 @@ subroutine allocatables(a) deallocate(a) a = 1. end select + ! Test nested associations + select rank(a) + rank default + select rank(a) + rank default + select rank(a) + rank (0) + allocate(a) ! ok + deallocate(a) ! ok + rank (1) + allocate(a(1)) ! ok + deallocate(a) ! ok + end select + end select + end select end subroutine pointers(p) real, pointer :: p(..) @@ -103,7 +117,6 @@ subroutine pointers(p) !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE rank (*) !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)