[flang-commits] [flang] [flang] Correct handling of assumed-rank allocatables in ALLOCATE (PR #66718)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Sep 18 15:57:40 PDT 2023
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/66718
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.
>From 89b55bce48f58692c2bd19613c607dd89c4e38aa Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 18 Sep 2023 15:36:35 -0700
Subject: [PATCH] [flang] Correct handling of assumed-rank allocatables in
ALLOCATE
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.
---
flang/lib/Evaluate/tools.cpp | 12 +++++++--
flang/lib/Semantics/check-allocate.cpp | 35 ++++++++++++++------------
flang/test/Semantics/select-rank03.f90 | 17 +++++++++++--
3 files changed, 44 insertions(+), 20 deletions(-)
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)
More information about the flang-commits
mailing list