llvm · klausler · Sep 13, 2023 · Aug 31, 2023
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
@@ -1224,10 +1224,11 @@ bool IsEventTypeOrLockType(const DerivedTypeSpec *);
 // of the construct entity.
 // (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
 // while GetAssociationRoot(x) returns y.)
-// ResolveAssociationsExceptSelectRank() stops at a RANK case symbol.
+// In a SELECT RANK construct, ResolveAssociations() stops at a
+// RANK(n) or RANK(*) case symbol, but traverses the selector for
+// RANK DEFAULT.
 const Symbol &ResolveAssociations(const Symbol &);
 const Symbol &GetAssociationRoot(const Symbol &);
-const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &);
 
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);

diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
@@ -278,12 +278,33 @@ class AssocEntityDetails : public EntityDetails {
   AssocEntityDetails &operator=(const AssocEntityDetails &) = default;
   AssocEntityDetails &operator=(AssocEntityDetails &&) = default;
   const MaybeExpr &expr() const { return expr_; }
+
+  // SELECT RANK's rank cases will return a populated result for
+  // RANK(n) and RANK(*), and IsAssumedRank() will be true for
+  // RANK DEFAULT.
+  std::optional<int> rank() const {
+    int r{rank_.value_or(0)};
+    if (r == isAssumedSize) {
+      return 1; // RANK(*)
+    } else if (r == isAssumedRank) {
+      return std::nullopt; // RANK DEFAULT
+    } else {
+      return rank_;
+    }
+  }
+  bool IsAssumedSize() const { return rank_.value_or(0) == isAssumedSize; }
+  bool IsAssumedRank() const { return rank_.value_or(0) == isAssumedRank; }
   void set_rank(int rank);
-  std::optional<int> rank() const { return rank_; }
+  void set_IsAssumedSize();
+  void set_IsAssumedRank();
 
 private:
   MaybeExpr expr_;
-  std::optional<int> rank_; // for SELECT RANK
+  // Populated for SELECT RANK with rank (n>=0) for RANK(n),
+  // isAssumedSize for RANK(*), or isAssumedRank for RANK DEFAULT.
+  static constexpr int isAssumedSize{-1}; // RANK(*)
+  static constexpr int isAssumedRank{-2}; // RANK DEFAULT
+  std::optional<int> rank_;
 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
 
@@ -862,12 +883,14 @@ class Symbol {
               return iface ? iface->RankImpl(depth) : 0;
             },
             [](const AssocEntityDetails &aed) {
-              if (const auto &expr{aed.expr()}) {
-                if (auto assocRank{aed.rank()}) {
-                  return *assocRank;
-                } else {
-                  return expr->Rank();
-                }
+              if (auto assocRank{aed.rank()}) {
+                // RANK(n) & RANK(*)
+                return *assocRank;
+              } else if (aed.IsAssumedRank()) {
+                // RANK DEFAULT
+                return 0;
+              } else if (const auto &expr{aed.expr()}) {
+                return expr->Rank();
               } else {
                 return 0;
               }

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
@@ -179,8 +179,13 @@ const Symbol *IsFinalizable(const DerivedTypeSpec &,
 const Symbol *HasImpureFinal(const Symbol &);
 bool IsInBlankCommon(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
-  const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
-  return details && details->IsAssumedSize();
+  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    return object->IsAssumedSize();
+  } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
+    return assoc->IsAssumedSize();
+  } else {
+    return false;
+  }
 }
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);

diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
@@ -248,17 +248,17 @@ class GetLowerBoundHelper
 
   Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {
     const Symbol &symbol{symbol0.GetUltimate()};
-    if (const auto *details{
+    if (const auto *object{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-      int rank{details->shape().Rank()};
+      int rank{object->shape().Rank()};
       if (dimension_ < rank) {
-        const semantics::ShapeSpec &shapeSpec{details->shape()[dimension_]};
+        const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]};
         if (shapeSpec.lbound().isExplicit()) {
           if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
             if constexpr (LBOUND_SEMANTICS) {
               bool ok{false};
               auto lbValue{ToInt64(*lbound)};
-              if (dimension_ == rank - 1 && details->IsAssumedSize()) {
+              if (dimension_ == rank - 1 && object->IsAssumedSize()) {
                 // last dimension of assumed-size dummy array: don't worry
                 // about handling an empty dimension
                 ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
@@ -309,7 +309,10 @@ class GetLowerBoundHelper
       }
     } else if (const auto *assoc{
                    symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-      if (assoc->rank()) { // SELECT RANK case
+      if (assoc->IsAssumedSize()) { // RANK(*)
+        return Result{1};
+      } else if (assoc->IsAssumedRank()) { // RANK DEFAULT
+      } else if (assoc->rank()) { // RANK(n)
         const Symbol &resolved{ResolveAssociations(symbol)};
         if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
           return ExtentExpr{DescriptorInquiry{std::move(base),
@@ -497,9 +500,11 @@ MaybeExtentExpr GetExtent(
     const NamedEntity &base, int dimension, bool invariantOnly) {
   CHECK(dimension >= 0);
   const Symbol &last{base.GetLastSymbol()};
-  const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)};
+  const Symbol &symbol{ResolveAssociations(last)};
   if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (assoc->rank()) { // SELECT RANK case
+    if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) { // RANK(*)/DEFAULT
+      return std::nullopt;
+    } else if (assoc->rank()) { // RANK(n)
       if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
         return ExtentExpr{DescriptorInquiry{
             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
@@ -595,8 +600,7 @@ MaybeExtentExpr ComputeUpperBound(
 
 MaybeExtentExpr GetRawUpperBound(
     const NamedEntity &base, int dimension, bool invariantOnly) {
-  const Symbol &symbol{
-      ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
+  const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
@@ -612,7 +616,11 @@ MaybeExtentExpr GetRawUpperBound(
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
+    if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
+      return std::nullopt;
+    } else if (assoc->rank() && dimension >= *assoc->rank()) {
+      return std::nullopt;
+    } else if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
       return ComputeUpperBound(
           GetRawLowerBound(base, dimension), std::move(extent));
     }
@@ -645,8 +653,7 @@ static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
 
 static MaybeExtentExpr GetUBOUND(FoldingContext *context,
     const NamedEntity &base, int dimension, bool invariantOnly) {
-  const Symbol &symbol{
-      ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
+  const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
@@ -662,7 +669,9 @@ static MaybeExtentExpr GetUBOUND(FoldingContext *context,
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (assoc->rank()) { // SELECT RANK case
+    if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
+      return std::nullopt;
+    } else if (assoc->rank()) { // RANK (n)
       const Symbol &resolved{ResolveAssociations(symbol)};
       if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
         ExtentExpr lb{DescriptorInquiry{NamedEntity{base},

diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
@@ -702,15 +702,14 @@ std::optional<Expr<SomeType>> ConvertToType(
 bool IsAssumedRank(const Symbol &original) {
   if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
     if (assoc->rank()) {
-      return false; // in SELECT RANK case
+      return false; // in RANK(n) or RANK(*)
+    } else if (assoc->IsAssumedRank()) {
+      return true; // RANK DEFAULT
     }
   }
   const Symbol &symbol{semantics::ResolveAssociations(original)};
-  if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    return details->IsAssumedRank();
-  } else {
-    return false;
-  }
+  const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+  return object && object->IsAssumedRank();
 }
 
 bool IsAssumedRank(const ActualArgument &arg) {
@@ -1209,17 +1208,7 @@ namespace Fortran::semantics {
 const Symbol &ResolveAssociations(const Symbol &original) {
   const Symbol &symbol{original.GetUltimate()};
   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
-    if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
-      return ResolveAssociations(*nested);
-    }
-  }
-  return symbol;
-}
-
-const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &original) {
-  const Symbol &symbol{original.GetUltimate()};
-  if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
-    if (!details->rank()) {
+    if (!details->rank()) { // Not RANK(n) or RANK(*)
       if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
         return ResolveAssociations(*nested);
       }

diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
@@ -39,16 +39,11 @@ class AllocationCheckerHelper {
 public:
   AllocationCheckerHelper(
       const parser::Allocation &alloc, AllocateCheckerInfo &info)
-      : allocateInfo_{info},
-        allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
-        name_{parser::GetLastName(allocateObject_)},
-        original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
-        symbol_{original_ ? &ResolveAssociations(*original_) : nullptr},
-        type_{symbol_ ? symbol_->GetType() : nullptr},
-        allocateShapeSpecRank_{ShapeSpecRank(alloc)},
-        rank_{original_ ? original_->Rank() : 0},
-        allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
-        corank_{symbol_ ? symbol_->Corank() : 0} {}
+      : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
+                                 alloc.t)},
+        allocateShapeSpecRank_{ShapeSpecRank(alloc)}, allocateCoarraySpecRank_{
+                                                          CoarraySpecRank(
+                                                              alloc)} {}
 
   bool RunChecks(SemanticsContext &context);
 
@@ -90,14 +85,17 @@ class AllocationCheckerHelper {
 
   AllocateCheckerInfo &allocateInfo_;
   const parser::AllocateObject &allocateObject_;
-  const parser::Name &name_;
-  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};
+  const int allocateShapeSpecRank_{0};
+  const int allocateCoarraySpecRank_{0};
+  const parser::Name &name_{parser::GetLastName(allocateObject_)};
+  // no USE or host association
+  const Symbol *original_{
+      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};
   bool hasDeferredTypeParameter_{false};
   bool isUnlimitedPolymorphic_{false};
   bool isAbstract_{false};
@@ -539,6 +537,11 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
     }
   }
   // Shape related checks
+  if (symbol_ && evaluate::IsAssumedRank(*symbol_)) {
+    context.Say(name_.source,
+        "An assumed-rank object may not appear in an ALLOCATE statement"_err_en_US);
+    return false;
+  }
   if (rank_ > 0) {
     if (!hasAllocateShapeSpecList()) {
       // C939

diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp
@@ -87,7 +87,7 @@ void SelectRankConstructChecker::Leave(
               }
               if (saveSelSymbol &&
                   IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
-                context_.Say(parser::FindSourceLocation(selectRankStmtSel),
+                context_.Say(rankCaseStmt.source,
                     "RANK (*) cannot be used when selector is "
                     "POINTER or ALLOCATABLE"_err_en_US);
               }

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
@@ -260,11 +260,11 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
           symbolRank, symbol.name(), subscripts);
     }
     return std::nullopt;
-  } else if (const auto *object{
-                 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+  } else if (symbol.has<semantics::ObjectEntityDetails>() ||
+      symbol.has<semantics::AssocEntityDetails>()) {
     // C928 & C1002
     if (Triplet *last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
-      if (!last->upper() && object->IsAssumedSize()) {
+      if (!last->upper() && IsAssumedSizeArray(symbol)) {
         Say("Assumed-size array '%s' must have explicit final "
             "subscript upper bound value"_err_en_US,
             symbol.name());

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
@@ -6942,17 +6942,32 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
 void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
   if (auto *symbol{MakeAssocEntity()}) {
     SetTypeFromAssociation(*symbol);
+    auto &details{symbol->get<AssocEntityDetails>()};
     // 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);
+    Attrs selectorAttrs{
+        evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
+    Attrs attrsToKeep{Attr::ASYNCHRONOUS, Attr::TARGET, Attr::VOLATILE};
+    if (const auto *rankValue{
+            std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
+      // RANK(n)
+      if (auto expr{EvaluateIntExpr(*rankValue)}) {
+        if (auto val{evaluate::ToInt64(*expr)}) {
+          details.set_rank(*val);
+          attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
+        } else {
+          Say("RANK() expression must be constant"_err_en_US);
+        }
       }
+    } else if (std::holds_alternative<parser::Star>(x.u)) {
+      // RANK(*): assumed-size
+      details.set_IsAssumedSize();
+    } else {
+      CHECK(std::holds_alternative<parser::Default>(x.u));
+      // RANK DEFAULT: assumed-rank
+      details.set_IsAssumedRank();
+      attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
     }
+    symbol->attrs() |= selectorAttrs & attrsToKeep;
   }
 }
 

diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
@@ -153,6 +153,8 @@ void EntityDetails::set_type(const DeclTypeSpec &type) {
 }
 
 void AssocEntityDetails::set_rank(int rank) { rank_ = rank; }
+void AssocEntityDetails::set_IsAssumedSize() { rank_ = isAssumedSize; }
+void AssocEntityDetails::set_IsAssumedRank() { rank_ = isAssumedRank; }
 void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
 
 ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
@@ -438,8 +440,12 @@ llvm::raw_ostream &operator<<(
 llvm::raw_ostream &operator<<(
     llvm::raw_ostream &os, const AssocEntityDetails &x) {
   os << *static_cast<const EntityDetails *>(&x);
-  if (auto assocRank{x.rank()}) {
-    os << " rank: " << *assocRank;
+  if (x.IsAssumedSize()) {
+    os << " RANK(*)";
+  } else if (x.IsAssumedRank()) {
+    os << " RANK DEFAULT";
+  } else if (auto assocRank{x.rank()}) {
+    os << " RANK(" << *assocRank << ')';
   }
   DumpExpr(os, "expr", x.expr());
   return os;