[flang-commits] [flang] [flang] Correct handling of assumed-rank allocatables in ALLOCATE (PR #66718)
via flang-commits
flang-commits at lists.llvm.org
Mon Sep 18 15:59:16 PDT 2023
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
<details>
<summary>Changes</summary>
Construct entities that are associations from selectors in ASSOCIATE, CHANGE TEAMS, and SELECT TYPE constructs do not have the ALLOCATABLE or POINTER attributes, even when associating with allocatables or pointers; associations from selectors in SELECT RANK constructs do have those attributes.
---
Full diff: https://github.com/llvm/llvm-project/pull/66718.diff
3 Files Affected:
- (modified) flang/lib/Evaluate/tools.cpp (+10-2)
- (modified) flang/lib/Semantics/check-allocate.cpp (+19-16)
- (modified) flang/test/Semantics/select-rank03.f90 (+15-2)
``````````diff
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index d5cdebd7e49f079..9d51649652537ed 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<AssocEntityDetails>()}) {
+ // 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 2edb8e59fd08406..ba1161b21f83676 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 f49767c5adf3323..234bd1a115493de 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)
``````````
</details>
https://github.com/llvm/llvm-project/pull/66718
More information about the flang-commits
mailing list