[flang] Support SELECT RANK on allocatables & pointers

Unlike other executable constructs with associating selectors, the
selector of a SELECT RANK construct can have the ALLOCATABLE or POINTER
attribute, and will work as an allocatable or object pointer within
each rank case, so long as there is no RANK(*) case.

Getting this right exposed a correctness risk with the popular
predicate IsAllocatableOrPointer() -- it will be true for procedure
pointers as well as object pointers, and in many contexts, a procedure
pointer should not be acceptable.  So this patch adds the new predicate
IsAllocatableOrObjectPointer(), and updates some call sites of the original
function to use the new one.

Differential Revision: https://reviews.llvm.org/D159043

flang/include/flang/Evaluate/tools.h

@@ -1189,7 +1189,10 @@ bool IsFunction(const Symbol &);
 bool IsFunction(const Scope &);
 bool IsProcedure(const Symbol &);
 bool IsProcedure(const Scope &);
+bool IsProcedurePointer(const Symbol *);
 bool IsProcedurePointer(const Symbol &);
+bool IsObjectPointer(const Symbol *);
+bool IsAllocatableOrObjectPointer(const Symbol *);
 bool IsAutomatic(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);

flang/include/flang/Semantics/symbol.h

@@ -237,7 +237,8 @@ class EntityDetails : public WithBindName {
       llvm::raw_ostream &, const EntityDetails &);
 };
 
-// Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE.
+// Symbol is associated with a name or expression in an ASSOCIATE,
+// SELECT TYPE, or SELECT RANK construct.
 class AssocEntityDetails : public EntityDetails {
 public:
   AssocEntityDetails() {}
@@ -252,7 +253,7 @@ class AssocEntityDetails : public EntityDetails {
 
 private:
   MaybeExpr expr_;
-  std::optional<int> rank_;
+  std::optional<int> rank_; // for SELECT RANK
 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
 

flang/include/flang/Semantics/tools.h

@@ -143,6 +143,7 @@ inline bool IsPointer(const Symbol &symbol) {
 inline bool IsAllocatable(const Symbol &symbol) {
   return symbol.attrs().test(Attr::ALLOCATABLE);
 }
+// IsAllocatableOrObjectPointer() may be the better choice
 inline bool IsAllocatableOrPointer(const Symbol &symbol) {
   return IsPointer(symbol) || IsAllocatable(symbol);
 }

flang/lib/Evaluate/intrinsics.cpp

@@ -2221,7 +2221,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       if (dummy[*dimArg].optionality == Optionality::required) {
         if (const Symbol *whole{
                 UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
-          if (IsOptional(*whole) || IsAllocatableOrPointer(*whole)) {
+          if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
             if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
               messages.Say(
                   "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US);

flang/lib/Evaluate/tools.cpp

@@ -1158,7 +1158,8 @@ std::optional<Expr<SomeType>> DataConstantConversionExtension(
 bool IsAllocatableOrPointerObject(
     const Expr<SomeType> &expr, FoldingContext &context) {
   const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
-  return (sym && semantics::IsAllocatableOrPointer(sym->GetUltimate())) ||
+  return (sym &&
+             semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
       evaluate::IsObjectPointer(expr, context);
 }
 
@@ -1388,17 +1389,39 @@ bool IsProcedure(const Scope &scope) {
   return symbol && IsProcedure(*symbol);
 }
 
+bool IsProcedurePointer(const Symbol &original) {
+  const Symbol &symbol{GetAssociationRoot(original)};
+  return IsPointer(symbol) && IsProcedure(symbol);
+}
+
+bool IsProcedurePointer(const Symbol *symbol) {
+  return symbol && IsProcedurePointer(*symbol);
+}
+
+bool IsObjectPointer(const Symbol *original) {
+  if (original) {
+    const Symbol &symbol{GetAssociationRoot(*original)};
+    return IsPointer(symbol) && !IsProcedure(symbol);
+  } else {
+    return false;
+  }
+}
+
+bool IsAllocatableOrObjectPointer(const Symbol *original) {
+  if (original) {
+    const Symbol &symbol{GetAssociationRoot(*original)};
+    return IsAllocatable(symbol) || (IsPointer(symbol) && !IsProcedure(symbol));
+  } else {
+    return false;
+  }
+}
+
 const Symbol *FindCommonBlockContaining(const Symbol &original) {
   const Symbol &root{GetAssociationRoot(original)};
   const auto *details{root.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;
 }
 
-bool IsProcedurePointer(const Symbol &original) {
-  const Symbol &symbol{GetAssociationRoot(original)};
-  return IsPointer(symbol) && IsProcedure(symbol);
-}
-
 // 3.11 automatic data object
 bool IsAutomatic(const Symbol &original) {
   const Symbol &symbol{original.GetUltimate()};
@@ -1516,14 +1539,14 @@ bool IsAssumedShape(const Symbol &symbol) {
   const Symbol &ultimate{ResolveAssociations(symbol)};
   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
   return object && object->CanBeAssumedShape() &&
-      !semantics::IsAllocatableOrPointer(ultimate);
+      !semantics::IsAllocatableOrObjectPointer(&ultimate);
 }
 
 bool IsDeferredShape(const Symbol &symbol) {
   const Symbol &ultimate{ResolveAssociations(symbol)};
   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
   return object && object->CanBeDeferredShape() &&
-      semantics::IsAllocatableOrPointer(ultimate);
+      semantics::IsAllocatableOrObjectPointer(&ultimate);
 }
 
 bool IsFunctionResult(const Symbol &original) {

flang/lib/Lower/Bridge.cpp

@@ -581,7 +581,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
                         llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {
       mlir::Value allocVal = builder->allocateLocal(
           loc,
-          Fortran::semantics::IsAllocatableOrPointer(hsym.GetUltimate())
+          Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())
               ? hSymType
               : symType,
           mangleName(sym), toStringRef(sym.GetUltimate().name()),

flang/lib/Lower/ConvertExprToHLFIR.cpp

@@ -129,7 +129,7 @@ class HlfirDesignatorBuilder {
     // shape is deferred and should not be loaded now to preserve
     // pointer/allocatable aspects.
     if (componentSym.Rank() == 0 ||
-        Fortran::semantics::IsAllocatableOrPointer(componentSym))
+        Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
       return mlir::Value{};
 
     fir::FirOpBuilder &builder = getBuilder();
@@ -488,8 +488,8 @@ class HlfirDesignatorBuilder {
       // array ref designates the target (this is done in "visit"). Other
       // components need special care to deal with the array%array_comp(indices)
       // case.
-      if (Fortran::semantics::IsAllocatableOrPointer(
-              component->GetLastSymbol()))
+      if (Fortran::semantics::IsAllocatableOrObjectPointer(
+              &component->GetLastSymbol()))
         baseType = visit(*component, partInfo);
       else
         baseType = hlfir::getFortranElementOrSequenceType(
@@ -734,7 +734,7 @@ class HlfirDesignatorBuilder {
       if (charTy.hasConstantLen())
         partInfo.typeParams.push_back(
             builder.createIntegerConstant(loc, idxTy, charTy.getLen()));
-      else if (!Fortran::semantics::IsAllocatableOrPointer(componentSym))
+      else if (!Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
         TODO(loc, "compute character length of automatic character component "
                   "in a PDT");
       // Otherwise, the length of the component is deferred and will only

flang/lib/Lower/IO.cpp

@@ -498,7 +498,7 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
     // A global pointer or allocatable variable has a descriptor for typical
     // accesses. Variables in multiple namelist groups may already have one.
     // Create descriptors for other cases.
-    if (!IsAllocatableOrPointer(s)) {
+    if (!IsAllocatableOrObjectPointer(&s)) {
       std::string mangleName =
           Fortran::lower::mangle::globalNamelistDescriptorName(s);
       if (builder.getNamedGlobal(mangleName))

flang/lib/Lower/Mangler.cpp

@@ -277,5 +277,5 @@ std::string Fortran::lower::mangle::mangleArrayLiteral(
 std::string Fortran::lower::mangle::globalNamelistDescriptorName(
     const Fortran::semantics::Symbol &sym) {
   std::string name = mangleName(sym);
-  return IsAllocatableOrPointer(sym) ? name : name + ".desc"s;
+  return IsAllocatableOrObjectPointer(&sym) ? name : name + ".desc"s;
 }

flang/lib/Lower/OpenMP.cpp

@@ -1553,7 +1553,8 @@ bool ClauseProcessor::processCopyin() const {
               checkAndCopyHostAssociateVar(&*mem, &insPt);
             break;
           }
-          if (Fortran::semantics::IsAllocatableOrPointer(sym->GetUltimate()))
+          if (Fortran::semantics::IsAllocatableOrObjectPointer(
+                  &sym->GetUltimate()))
             TODO(converter.getCurrentLocation(),
                  "pointer or allocatable variables in Copyin clause");
           assert(sym->has<Fortran::semantics::HostAssocDetails>() &&
@@ -1815,7 +1816,7 @@ static fir::GlobalOp globalInitialization(
       firOpBuilder.createGlobal(currentLocation, ty, globalName, linkage);
 
   // Create default initialization for non-character scalar.
-  if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
+  if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) {
     mlir::Type baseAddrType = ty.dyn_cast<fir::BoxType>().getEleTy();
     Fortran::lower::createGlobalInitialization(
         firOpBuilder, global, [&](fir::FirOpBuilder &b) {

flang/lib/Semantics/check-allocate.cpp

@@ -39,14 +39,14 @@ class AllocationCheckerHelper {
 public:
   AllocationCheckerHelper(
       const parser::Allocation &alloc, AllocateCheckerInfo &info)
-      : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
-                                 alloc.t)},
+      : allocateInfo_{info},
+        allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
         name_{parser::GetLastName(allocateObject_)},
-        symbol_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
+        original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
+        symbol_{original_ ? &ResolveAssociations(*original_) : nullptr},
         type_{symbol_ ? symbol_->GetType() : nullptr},
-        allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{symbol_
-                                                              ? symbol_->Rank()
-                                                              : 0},
+        allocateShapeSpecRank_{ShapeSpecRank(alloc)},
+        rank_{original_ ? original_->Rank() : 0},
         allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
         corank_{symbol_ ? symbol_->Corank() : 0} {}
 
@@ -91,7 +91,8 @@ class AllocationCheckerHelper {
   AllocateCheckerInfo &allocateInfo_;
   const parser::AllocateObject &allocateObject_;
   const parser::Name &name_;
-  const Symbol *symbol_{nullptr};
+  const Symbol *original_{nullptr}; // no USE or host association
+  const Symbol *symbol_{nullptr}; // no USE, host, or construct association
   const DeclTypeSpec *type_{nullptr};
   const int allocateShapeSpecRank_;
   const int rank_{0};
@@ -558,17 +559,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
         }
       }
     } else {
-      // first part of C942
+      // explicit shape-spec-list
       if (allocateShapeSpecRank_ != rank_) {
         context
             .Say(name_.source,
                 "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
-            .Attach(symbol_->name(), "Declared here with rank %d"_en_US, rank_);
+            .Attach(
+                original_->name(), "Declared here with rank %d"_en_US, rank_);
         return false;
       }
     }
-  } else {
-    // C940
+  } else { // allocating a scalar object
     if (hasAllocateShapeSpecList()) {
       context.Say(name_.source,
           "Shape specifications must not appear when allocatable object is scalar"_err_en_US);

flang/lib/Semantics/check-call.cpp

@@ -1430,7 +1430,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
               whole->name());
         } else if (context.ShouldWarn(
                        common::UsageWarning::TransferSizePresence) &&
-            IsAllocatableOrPointer(*whole)) {
+            IsAllocatableOrObjectPointer(whole)) {
           messages.Say(
               "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
         }

flang/lib/Semantics/check-deallocate.cpp

@@ -19,20 +19,18 @@ namespace Fortran::semantics {
 void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
   for (const parser::AllocateObject &allocateObject :
       std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
-    parser::CharBlock source;
-    const Symbol *symbol{nullptr};
     common::visit(
         common::visitors{
             [&](const parser::Name &name) {
-              source = name.source;
-              symbol = name.symbol;
+              const Symbol *symbol{
+                  name.symbol ? &name.symbol->GetUltimate() : nullptr};
+              ;
               if (context_.HasError(symbol)) {
                 // already reported an error
               } else if (!IsVariableName(*symbol)) {
                 context_.Say(name.source,
                     "Name in DEALLOCATE statement must be a variable name"_err_en_US);
-              } else if (!IsAllocatableOrPointer(
-                             symbol->GetUltimate())) { // C932
+              } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
                 context_.Say(name.source,
                     "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
               } else if (auto whyNot{WhyNotDefinable(name.source,
@@ -61,30 +59,32 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
             [&](const parser::StructureComponent &structureComponent) {
               // Only perform structureComponent checks if it was successfully
               // analyzed by expression analysis.
-              source = structureComponent.component.source;
-              symbol = structureComponent.component.symbol;
+              auto source{structureComponent.component.source};
               if (const auto *expr{GetExpr(context_, allocateObject)}) {
-                if (symbol) {
-                  if (!IsAllocatableOrPointer(*symbol)) { // C932
-                    context_.Say(source,
-                        "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
-                  } else if (auto whyNot{WhyNotDefinable(source,
-                                 context_.FindScope(source),
-                                 {DefinabilityFlag::PointerDefinition,
-                                     DefinabilityFlag::AcceptAllocatable},
-                                 *expr)}) {
-                    context_
-                        .Say(source,
-                            "Name in DEALLOCATE statement is not definable"_err_en_US)
-                        .Attach(std::move(*whyNot));
-                  } else if (auto whyNot{WhyNotDefinable(source,
-                                 context_.FindScope(source),
-                                 DefinabilityFlags{}, *expr)}) {
-                    context_
-                        .Say(source,
-                            "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
-                        .Attach(std::move(*whyNot));
-                  }
+                if (const Symbol *
+                        symbol{structureComponent.component.symbol
+                                ? &structureComponent.component.symbol
+                                       ->GetUltimate()
+                                : nullptr};
+                    !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
+                  context_.Say(source,
+                      "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                } else if (auto whyNot{WhyNotDefinable(source,
+                               context_.FindScope(source),
+                               {DefinabilityFlag::PointerDefinition,
+                                   DefinabilityFlag::AcceptAllocatable},
+                               *expr)}) {
+                  context_
+                      .Say(source,
+                          "Name in DEALLOCATE statement is not definable"_err_en_US)
+                      .Attach(std::move(*whyNot));
+                } else if (auto whyNot{WhyNotDefinable(source,
+                               context_.FindScope(source), DefinabilityFlags{},
+                               *expr)}) {
+                  context_
+                      .Say(source,
+                          "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+                      .Attach(std::move(*whyNot));
                 }
               }
             },

flang/lib/Semantics/check-declarations.cpp

@@ -731,7 +731,7 @@ void CheckHelper::CheckObjectEntity(
             "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
       }
       if (IsPassedViaDescriptor(symbol)) {
-        if (IsAllocatableOrPointer(symbol)) {
+        if (IsAllocatableOrObjectPointer(&symbol)) {
           if (inExplicitInterface) {
             WarnIfNotInModuleFile(
                 "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);

flang/lib/Semantics/check-omp-structure.cpp

@@ -203,8 +203,8 @@ void OmpStructureChecker::CheckMultListItems() {
                 "ALIGNED clause"_err_en_US,
                 name->ToString());
           } else if (!(IsBuiltinCPtr(*(name->symbol)) ||
-                         IsAllocatableOrPointer(
-                             (name->symbol->GetUltimate())))) {
+                         IsAllocatableOrObjectPointer(
+                             &name->symbol->GetUltimate()))) {
             context_.Say(itr->second->source,
                 "'%s' in ALIGNED clause must be of type C_PTR, POINTER or "
                 "ALLOCATABLE"_err_en_US,

flang/lib/Semantics/check-select-rank.cpp

@@ -86,7 +86,7 @@ void SelectRankConstructChecker::Leave(
                     .Attach(prevLocStar, "Previous use"_en_US);
               }
               if (saveSelSymbol &&
-                  IsAllocatableOrPointer(*saveSelSymbol)) { // C1155
+                  IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
                 context_.Say(parser::FindSourceLocation(selectRankStmtSel),
                     "RANK (*) cannot be used when selector is "
                     "POINTER or ALLOCATABLE"_err_en_US);

flang/lib/Semantics/definable.cpp

@@ -169,7 +169,7 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
   const Symbol &ultimate{original.GetUltimate()};
   if (flags.test(DefinabilityFlag::PointerDefinition)) {
     if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
-      if (!IsAllocatableOrPointer(ultimate)) {
+      if (!IsAllocatableOrObjectPointer(&ultimate)) {
         return BlameSymbol(
             at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
       }

flang/lib/Semantics/resolve-directives.cpp

@@ -1113,7 +1113,7 @@ void AccAttributeVisitor::EnsureAllocatableOrPointer(
         common::visitors{
             [&](const parser::Designator &designator) {
               const auto &lastName{GetLastName(designator)};
-              if (!IsAllocatableOrPointer(*lastName.symbol)) {
+              if (!IsAllocatableOrObjectPointer(lastName.symbol)) {
                 context_.Say(designator.source,
                     "Argument `%s` on the %s clause must be a variable or "
                     "array with the POINTER or ALLOCATABLE attribute"_err_en_US,