[flang] Correct handling of assumed-rank allocatables in ALLOCATE (#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.

Author: klausler

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

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

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)