[flang] Correct handling of assumed-rank allocatables in ALLOCATE

[klausler]

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.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Changes

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 --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)