Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-10-07 10:54:01 +00:00
Code Issues Actions 4 Packages Projects Releases Wiki Activity

[flang] Correct handling of assumed-rank allocatables in ALLOCATE (#66718)

Browse Source 
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.
This commit is contained in:
Peter Klausler 2023-09-19 12:27:35 -07:00 committed by GitHub
parent 01475dc29a
commit 682270877d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 44 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
flang/lib/Evaluate/tools.cpp
View File

@ -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;
}

35
flang/lib/Semantics/check-allocate.cpp
View File

@ -89,13 +89,11 @@ private:
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;
}
}

17
flang/test/Semantics/select-rank03.f90
View File

@ -46,7 +46,6 @@ program test
!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 @@ program test
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 @@ program test
!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)