[flang] Support SELECT RANK on allocatables & pointers

[klausler]

Summary

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.

[vzakhari]

Thank you! Looks great!

[klausler]

Try another version of clang-format.

flang/include/flang/Evaluate/tools.h

 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
 bool IsElementalProcedure(const Symbol &);
 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 &);
 bool IsAssumedShape(const Symbol &);
 bool IsDeferredShape(const Symbol &);
 bool IsFunctionResult(const Symbol &);
 bool IsKindTypeParameter(const Symbol &);
 bool IsLenTypeParameter(const Symbol &);

flang/include/flang/Semantics/symbol.h

 private:
   bool isDummy_{false};
   bool isFuncResult_{false};
   const DeclTypeSpec *type_{nullptr};
   friend llvm::raw_ostream &operator<<(
       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() {}
   explicit AssocEntityDetails(SomeExpr &&expr) : expr_{std::move(expr)} {}
   AssocEntityDetails(const AssocEntityDetails &) = default;
   AssocEntityDetails(AssocEntityDetails &&) = default;
   AssocEntityDetails &operator=(const AssocEntityDetails &) = default;
   AssocEntityDetails &operator=(AssocEntityDetails &&) = default;
   const MaybeExpr &expr() const { return expr_; }
   void set_rank(int rank);
   std::optional<int> rank() const { return rank_; }
 
 private:
   MaybeExpr expr_;
-  std::optional<int> rank_;
+  std::optional<int> rank_; // for SELECT RANK
 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
 
 // An entity known to be an object.
 class ObjectEntityDetails : public EntityDetails {
 public:
   explicit ObjectEntityDetails(EntityDetails &&);
   ObjectEntityDetails(const ObjectEntityDetails &) = default;

flang/include/flang/Semantics/tools.h

const Symbol *FindImmediateComponent(
     const DerivedTypeSpec &, const std::function<bool(const Symbol &)> &);
 
 inline bool IsPointer(const Symbol &symbol) {
   return symbol.attrs().test(Attr::POINTER);
 }
 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);
 }
 inline bool IsNamedConstant(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PARAMETER);
 }
 inline bool IsOptional(const Symbol &symbol) {
   return symbol.attrs().test(Attr::OPTIONAL);

flang/lib/Evaluate/intrinsics.cpp

if (dimArg) {
     switch (rank) {
     case Rank::dimReduced:
     case Rank::dimRemovedOrScalar:
     case Rank::locReduced:
     case Rank::scalarIfDim:
       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);
             } else {
               messages.Say(
                   "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US);
             }
           }

flang/lib/Evaluate/tools.cpp

if (auto fromType{expr.GetType()}) {
     }
   }
   return std::nullopt;
 }
 
 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);
 }
 
 bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
   // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).
   if (const semantics::Symbol *
       sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {
     return semantics::IsAllocatable(sym->GetUltimate());
return common::visit(common::visitors{
       symbol.GetUltimate().details());
 }
 
 bool IsProcedure(const Scope &scope) {
   const Symbol *symbol{scope.GetSymbol()};
   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()};
   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
       if (const DeclTypeSpec * type{symbol.GetType()}) {
         // If a type parameter value is not a constant expression, the
         // object is automatic.
return common::visit(
           [](const auto &) { return false; }},
       ResolveAssociations(symbol).details());
 }
 
 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) {
   const Symbol &symbol{GetAssociationRoot(original)};
   return common::visit(
       common::visitors{
           [](const EntityDetails &x) { return x.isFuncResult(); },
           [](const ObjectEntityDetails &x) { return x.isFuncResult(); },

flang/lib/Lower/Bridge.cpp

bool createHostAssociateVarClone(
     const Fortran::semantics::Symbol &hsym = details->symbol();
     mlir::Type hSymType = genType(hsym);
     Fortran::lower::SymbolBox hsb = lookupSymbol(hsym);
 
     auto allocate = [&](llvm::ArrayRef<mlir::Value> shape,
                         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()),
           /*pinned=*/true, shape, typeParams,
           sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET));
       return allocVal;
     };
 

flang/lib/Lower/ConvertExprToHLFIR.cpp

hlfir::ElementalAddrOp convertVectorSubscriptedExprToElementalAddr(
       const Fortran::lower::SomeExpr &designatorExpr);
 
   mlir::Value genComponentShape(const Fortran::semantics::Symbol &componentSym,
                                 mlir::Type fieldType) {
     // For pointers and allocatable components, the
     // 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();
     mlir::Location loc = getLoc();
     mlir::Type idxTy = builder.getIndexType();
     llvm::SmallVector<mlir::Value> extents;
     auto seqTy = hlfir::getFortranElementOrSequenceType(fieldType)
                      .cast<fir::SequenceType>();
private:
   mlir::Type visit(const Fortran::evaluate::ArrayRef &arrayRef,
                    PartInfo &partInfo) {
     mlir::Type baseType;
     if (const auto *component = arrayRef.base().UnwrapComponent()) {
       // Pointers and allocatable components must be dereferenced since the
       // 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(
             visitComponentImpl(*component, partInfo).second);
     } else {
       baseType = visit(arrayRef.base().GetLastSymbol(), partInfo);
     }
 
if (fir::isRecordWithTypeParameters(fieldEleType))
       TODO(loc,
            "lower a component that is a parameterized derived type to HLFIR");
     if (auto charTy = fieldEleType.dyn_cast<fir::CharacterType>()) {
       mlir::Location loc = getLoc();
       mlir::Type idxTy = builder.getIndexType();
       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
       // be read when the component is dereferenced.
     }
     return {baseType, fieldType};
   }
 

flang/lib/Lower/IO.cpp

for (const Fortran::semantics::Symbol &s : details.objects()) {
     stringAddress(s);
     if (!Fortran::lower::symbolIsGlobal(s)) {
       groupIsLocal = true;
       continue;
     }
     // 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))
         continue;
       const auto expr = Fortran::evaluate::AsGenericExpr(s);
       fir::BoxType boxTy =
           fir::BoxType::get(fir::PointerType::get(converter.genType(s)));
       auto descFunc = [&](fir::FirOpBuilder &b) {

flang/lib/Lower/Mangler.cpp

std::string Fortran::lower::mangle::mangleArrayLiteral(
   if (!size)
     name += "null.";
   return name;
 }
 
 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

bool hasCopyin = findRepeatableClause<ClauseTy::Copyin>(
         for (const Fortran::parser::OmpObject &ompObject : ompObjectList.v) {
           Fortran::semantics::Symbol *sym = getOmpObjectSymbol(ompObject);
           if (const auto *commonDetails =
                   sym->detailsIf<Fortran::semantics::CommonBlockDetails>()) {
             for (const auto &mem : commonDetails->objects())
               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>() &&
                  "No host-association found");
           checkAndCopyHostAssociateVar(sym);
         }
       });
 
static fir::GlobalOp globalInitialization(
     const Fortran::lower::pft::Variable &var, mlir::Location currentLocation) {
   mlir::Type ty = converter.genType(sym);
   std::string globalName = converter.mangleName(sym);
   mlir::StringAttr linkage = firOpBuilder.createInternalLinkage();
   fir::GlobalOp global =
       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) {
           mlir::Value nullAddr =
               b.createNullConstant(currentLocation, baseAddrType);
           mlir::Value box =
               b.create<fir::EmboxOp>(currentLocation, ty, nullAddr);
           b.create<fir::HasValueOp>(currentLocation, box);

flang/lib/Semantics/check-allocate.cpp

struct AllocateCheckerInfo {
   bool gotStream{false};
   bool gotPinned{false};
 };
 
 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} {}
 
   bool RunChecks(SemanticsContext &context);
 
 private:
   bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }
   bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }
void GatherAllocationBasicInfo() {
     }
     isUnlimitedPolymorphic_ =
         type_->category() == DeclTypeSpec::Category::ClassStar;
   }
 
   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};
   const int allocateCoarraySpecRank_;
   const int corank_{0};
   bool hasDeferredTypeParameter_{false};
   bool isUnlimitedPolymorphic_{false};
   bool isAbstract_{false};
if (!hasAllocateShapeSpecList()) {
               .Attach(allocateInfo_.sourceExprLoc.value(),
                   "Expression in %s has rank %d but allocatable object has rank %d"_en_US,
                   allocateInfo_.gotSource ? "SOURCE" : "MOLD",
                   allocateInfo_.sourceExprRank, rank_);
           return false;
         }
       }
     } 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);
       return false;
     }
   }
   // second and last part of C945
   if (allocateInfo_.gotSource && allocateInfo_.sourceExprRank &&

flang/lib/Semantics/check-call.cpp

if (arguments.size() > 2) { // SIZE=
       if (const Symbol *
           whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) {
         if (IsOptional(*whole)) {
           messages.Say(
               "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,
               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

 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/tools.h"
 
 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,
                              context_.FindScope(name.source),
                              {DefinabilityFlag::PointerDefinition,
                                  DefinabilityFlag::AcceptAllocatable},
                              *symbol)}) {
                 // Catch problems with non-definability of the
common::visit(
                     .Attach(std::move(*whyNot));
               } else {
                 context_.CheckIndexVarRedefine(name);
               }
             },
             [&](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_.FindScope(source), DefinabilityFlags{},
+                               *expr)}) {
             },
         },
         allocateObject.u);
   }
   bool gotStat{false}, gotMsg{false};
   for (const parser::StatOrErrmsg &deallocOpt :
       std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
     common::visit(

flang/lib/Semantics/check-declarations.cpp

if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
             "!DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array"_err_en_US);
       }
       if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
           details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
         messages_.Say(
             "!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);
           } else {
             messages_.Say(
                 "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
           }
         } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {

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

for (const auto &ompObject : alignedList.v) {
       if (const auto *name{parser::Unwrap<parser::Name>(ompObject)}) {
         if (name->symbol) {
           if (FindCommonBlockContaining(*(name->symbol))) {
             context_.Say(itr->second->source,
                 "'%s' is a common block name and can not appear in an "
                 "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,
                 name->ToString());
           } else {
             alignedNameList.push_back(*name);
           }
         } else {

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

common::visit(
               } else {
                 context_
                     .Say(rankCaseStmt.source,
                         "Not more than one of the selectors of SELECT RANK "
                         "statement may be '*'"_err_en_US)
                     .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);
               }
             },
             [&](const parser::ScalarIntConstantExpr &init) {
               if (auto val{GetIntValue(init)}) {
                 // If value is in valid range, then only show

flang/lib/Semantics/definable.cpp

static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
   return std::nullopt;
 }
 
 static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   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);
       }
     } else if (!IsPointer(ultimate)) {
       return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
     }
     return std::nullopt; // pointer assignment - skip following checks
   }

flang/lib/Semantics/resolve-directives.cpp

 
 void AccAttributeVisitor::EnsureAllocatableOrPointer(
     const llvm::acc::Clause clause, const parser::AccObjectList &objectList) {
   for (const auto &accObject : objectList.v) {
     common::visit(
         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,
                     lastName.symbol->name(),
                     parser::ToUpperCaseLetters(
                         llvm::acc::getOpenACCClauseName(clause).str()));
               }
             },

flang/lib/Semantics/resolve-names.cpp

if (auto *symbol{MakeAssocEntity()}) {
     }
     SetAttrsFromAssociation(*symbol);
   }
 }
 
 void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
   if (auto *symbol{MakeAssocEntity()}) {
     SetTypeFromAssociation(*symbol);
-    SetAttrsFromAssociation(*symbol);
+    // Don't call SetAttrsFromAssociation() for SELECT RANK.
+    symbol->attrs() |=
+        evaluate::GetAttrs(GetCurrentAssociation().selector.expr) &
+        Attrs{Attr::ALLOCATABLE, Attr::ASYNCHRONOUS, Attr::POINTER,
+            Attr::TARGET, Attr::VOLATILE};
     if (const auto *init{std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
       if (auto val{EvaluateInt64(context(), *init)}) {
         auto &details{symbol->get<AssocEntityDetails>()};
         details.set_rank(*val);
       }
     }
   }
 }
if (*pexpr) {
     } else {
       // BOZ literals, procedure designators, &c. are not acceptable
       Say(symbol.name(), "Associate name '%s' must have a type"_err_en_US);
     }
   }
 }
 
 // If current selector is a variable, set some of its attributes on symbol.
+// For ASSOCIATE, CHANGE TEAM, and SELECT TYPE only; not SELECT RANK.
 void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) {
   Attrs attrs{evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
   symbol.attrs() |=
       attrs & Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE};
   if (attrs.test(Attr::POINTER)) {
     SetImplicitAttr(symbol, Attr::TARGET);
   }
 }

flang/lib/Semantics/tools.cpp

ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
   if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
     if (const DeclTypeSpec * type{details->type()}) {
       if (const auto *derived{type->AsDerived()}) {
         bool traverse{false};
         if constexpr (componentKind == ComponentKind::Ordered) {
           // Order Component (only visit parents)
           traverse = component.test(Symbol::Flag::ParentComp);
         } else if constexpr (componentKind == ComponentKind::Direct) {
-          traverse = !IsAllocatableOrPointer(component);
+          traverse = !IsAllocatableOrObjectPointer(&component);
         } else if constexpr (componentKind == ComponentKind::Ultimate) {
-          traverse = !IsAllocatableOrPointer(component);
+          traverse = !IsAllocatableOrObjectPointer(&component);
         } else if constexpr (componentKind == ComponentKind::Potential) {
           traverse = !IsPointer(component);
         } else if constexpr (componentKind == ComponentKind::Scope) {
-          traverse = !IsAllocatableOrPointer(component);
+          traverse = !IsAllocatableOrObjectPointer(&component);
         } else if constexpr (componentKind ==
             ComponentKind::PotentialAndPointer) {
           traverse = !IsPointer(component);
         }
         if (traverse) {
           const Symbol &newTypeSymbol{derived->typeSymbol()};
           // Avoid infinite loop if the type is already part of the types
           // being visited. It is possible to have "loops in type" because
static bool StopAtComponentPre(const Symbol &component) {
   if constexpr (componentKind == ComponentKind::Ordered) {
     // Parent components need to be iterated upon after their
     // sub-components in structure constructor analysis.
     return !component.test(Symbol::Flag::ParentComp);
   } else if constexpr (componentKind == ComponentKind::Direct) {
     return true;
   } else if constexpr (componentKind == ComponentKind::Ultimate) {
     return component.has<ProcEntityDetails>() ||
-        IsAllocatableOrPointer(component) ||
+        IsAllocatableOrObjectPointer(&component) ||
         (component.get<ObjectEntityDetails>().type() &&
             component.get<ObjectEntityDetails>().type()->AsIntrinsic());
   } else if constexpr (componentKind == ComponentKind::Potential) {
     return !IsPointer(component);
   } else if constexpr (componentKind == ComponentKind::PotentialAndPointer) {
     return true;
   }
 }

flang/test/Semantics/select-rank03.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+program test
+  real, allocatable :: a0, a1(:)
+  real, pointer :: p0, p1(:)
+  real, target :: t0, t1(1)
+ contains
+  subroutine allocatables(a)
+    real, allocatable :: a(..)
+    !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+    select rank(a)
+    rank (0)
+      allocate(a) ! ok
+      deallocate(a) ! ok
+      allocate(a, source=a0) ! ok
+      allocate(a, mold=p0) ! ok
+      a = 1. ! ok
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar REAL(4) and rank 1 array of REAL(4)
+      a = [1.]
+      !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE
+      allocate(a, source=a1)
+      allocate(a, mold=p1) ! ok, mold= ignored
+    rank (1)
+      allocate(a(1)) ! ok
+      deallocate(a) ! ok
+      a = 1. ! ok
+      a = [1.] ! ok
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, source=a0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, mold=p0)
+      allocate(a, source=a1) ! ok
+      allocate(a, mold=p1) ! ok
+    rank (2)
+      allocate(a(1,1)) ! ok
+      deallocate(a) ! ok
+      a = 1. ! ok
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 2 array of REAL(4) and rank 1 array of REAL(4)
+      a = [1.]
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, source=a0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, mold=p0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, source=a1)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a, mold=p1)
+    rank (*)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a)
+      deallocate(a)
+      a = 1.
+    rank default
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(a)
+      deallocate(a)
+      a = 1.
+    end select
+  end
+  subroutine pointers(p)
+    real, pointer :: p(..)
+    !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+    select rank(p)
+    rank (0)
+      allocate(p) ! ok
+      deallocate(p) ! ok
+      allocate(p, source=a0) ! ok
+      allocate(p, mold=p0) ! ok
+      !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE
+      allocate(p, source=a1)
+      allocate(p, mold=p1) ! ok, mold ignored
+      p => t0 ! ok
+      !ERROR: Pointer has rank 0 but target has rank 1
+      p => t1
+    rank (1)
+      allocate(p(1)) ! ok
+      deallocate(p) ! ok
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, source=a0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, mold=p0)
+      allocate(p, source=a1) ! ok
+      allocate(p, mold=p1) ! ok
+      !ERROR: Pointer has rank 1 but target has rank 0
+      p => t0
+      p => t1 ! ok
+    rank (2)
+      allocate(p(1,1)) ! ok
+      deallocate(p) ! ok
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, source=a0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, mold=p0)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, source=a1)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p, mold=p1)
+      !ERROR: Pointer has rank 2 but target has rank 0
+      p => t0
+      !ERROR: Pointer has rank 2 but target has rank 1
+      p => t1
+    rank (*)
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p)
+      deallocate(p)
+    rank default
+      !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+      allocate(p)
+      deallocate(p)
+      !ERROR: pointer 'p' associated with object 't0' with incompatible type or shape
+      p => t0
+      !ERROR: pointer 'p' associated with object 't1' with incompatible type or shape
+      p => t1
+    end select
+  end
+end