[flang] More support for assumed-size Cray pointees (#77381)

Recognize Cray pointees as such when they are declared as assumed size
arrays, and don't emit a bogus error message about implied shape arrays.

Fixes https://github.com/llvm/llvm-project/issues/77330.

9 files changed, 43 insertions, 41 deletions

diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 056bad5..d257da1 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1244,6 +1244,16 @@ bool IsBadCoarrayType(const DerivedTypeSpec *);
 // Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
 bool IsIsoCType(const DerivedTypeSpec *);
 bool IsEventTypeOrLockType(const DerivedTypeSpec *);
+inline bool IsAssumedSizeArray(const Symbol &symbol) {
+  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    return (object->isDummy() || symbol.test(Symbol::Flag::CrayPointee)) &&
+        object->shape().CanBeAssumedSize();
+  } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
+    return assoc->IsAssumedSize();
+  } else {
+    return false;
+  }
+}
 
 // ResolveAssociations() traverses use associations and host associations
 // like GetUltimate(), but also resolves through whole variable associations
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index ea3be14..5163d66 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -362,11 +362,10 @@ public:
   void set_ignoreTKR(common::IgnoreTKRSet set) { ignoreTKR_ = set; }
   bool IsArray() const { return !shape_.empty(); }
   bool IsCoarray() const { return !coshape_.empty(); }
-  bool CanBeAssumedShape() const {
+  bool IsAssumedShape() const {
     return isDummy() && shape_.CanBeAssumedShape();
   }
   bool CanBeDeferredShape() const { return shape_.CanBeDeferredShape(); }
-  bool IsAssumedSize() const { return isDummy() && shape_.CanBeAssumedSize(); }
   bool IsAssumedRank() const { return isDummy() && shape_.IsAssumedRank(); }
   std::optional<common::CUDADataAttr> cudaDataAttr() const {
     return cudaDataAttr_;
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index b245081..38ae3e3 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -188,15 +188,6 @@ bool MayRequireFinalization(const DerivedTypeSpec &derived);
 bool HasAllocatableDirectComponent(const DerivedTypeSpec &derived);
 
 bool IsInBlankCommon(const Symbol &);
-inline bool IsAssumedSizeArray(const Symbol &symbol) {
-  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 &);
 bool IsModuleProcedure(const Symbol &);
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 83ef5d0..ae705fb 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -215,9 +215,10 @@ std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
 void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
   if (IsAssumedShape(symbol)) {
     attrs_.set(Attr::AssumedShape);
-  }
-  if (IsDeferredShape(symbol)) {
+  } else if (IsDeferredShape(symbol)) {
     attrs_.set(Attr::DeferredShape);
+  } else if (semantics::IsAssumedSizeArray(symbol)) {
+    attrs_.set(Attr::AssumedSize);
   }
   if (const auto *object{
           symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
@@ -225,9 +226,6 @@ void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
     if (object->IsAssumedRank()) {
       attrs_.set(Attr::AssumedRank);
     }
-    if (object->IsAssumedSize()) {
-      attrs_.set(Attr::AssumedSize);
-    }
     if (object->IsCoarray()) {
       attrs_.set(Attr::Coarray);
     }
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index c356af7..ff70d69 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -258,7 +258,8 @@ public:
             if constexpr (LBOUND_SEMANTICS) {
               bool ok{false};
               auto lbValue{ToInt64(*lbound)};
-              if (dimension_ == rank - 1 && object->IsAssumedSize()) {
+              if (dimension_ == rank - 1 &&
+                  semantics::IsAssumedSizeArray(symbol)) {
                 // last dimension of assumed-size dummy array: don't worry
                 // about handling an empty dimension
                 ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
@@ -527,7 +528,8 @@ MaybeExtentExpr GetExtent(
         if (j++ == dimension) {
           if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
             return extent;
-          } else if (details->IsAssumedSize() && j == symbol.Rank()) {
+          } else if (semantics::IsAssumedSizeArray(symbol) &&
+              j == symbol.Rank()) {
             break;
           } else if (semantics::IsDescriptor(symbol)) {
             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
@@ -608,7 +610,8 @@ MaybeExtentExpr GetRawUpperBound(
       const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
       if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) {
         return *bound;
-      } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
+      } else if (semantics::IsAssumedSizeArray(symbol) &&
+          dimension + 1 == symbol.Rank()) {
         return std::nullopt;
       } else {
         return ComputeUpperBound(
@@ -661,7 +664,8 @@ static MaybeExtentExpr GetUBOUND(FoldingContext *context,
       const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};
       if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {
         return *ubound;
-      } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
+      } else if (semantics::IsAssumedSizeArray(symbol) &&
+          dimension + 1 == symbol.Rank()) {
         return std::nullopt; // UBOUND() folding replaces with -1
       } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
         return ComputeUpperBound(
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index e57058c..131bbd9 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1703,7 +1703,7 @@ bool IsDummy(const Symbol &symbol) {
 bool IsAssumedShape(const Symbol &symbol) {
   const Symbol &ultimate{ResolveAssociations(symbol)};
   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
-  return object && object->CanBeAssumedShape() &&
+  return object && object->IsAssumedShape() &&
       !semantics::IsAllocatableOrObjectPointer(&ultimate);
 }
 
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 9c5c57a..a369e07 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -87,6 +87,9 @@ bool IsPassedViaDescriptor(const Symbol &symbol) {
   if (IsAllocatableOrPointer(symbol)) {
     return true;
   }
+  if (semantics::IsAssumedSizeArray(symbol)) {
+    return false;
+  }
   if (const auto *object{
           symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
     if (object->isDummy()) {
@@ -94,9 +97,6 @@ bool IsPassedViaDescriptor(const Symbol &symbol) {
           object->type()->category() == DeclTypeSpec::Character) {
         return false;
       }
-      if (object->IsAssumedSize()) {
-        return false;
-      }
       bool isExplicitShape{true};
       for (const ShapeSpec &shapeSpec : object->shape()) {
         if (!shapeSpec.lbound().GetExplicit() ||
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 93acb60..7944af7 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -683,7 +683,7 @@ void CheckHelper::CheckObjectEntity(
         messages_.Say(
             "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
       }
-      if (details.IsAssumedSize()) { // C834
+      if (IsAssumedSizeArray(symbol)) { // C834
         if (type && type->IsPolymorphic()) {
           messages_.Say(
               "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
@@ -1119,11 +1119,11 @@ void CheckHelper::CheckArraySpec(
   bool isCUDAShared{
       GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
       common::CUDADataAttr::Shared};
+  bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};
   std::optional<parser::MessageFixedText> msg;
-  if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit &&
-      !canBeAssumedSize) {
-    msg = "Cray pointee '%s' must have explicit shape or"
-          " assumed size"_err_en_US;
+  if (isCrayPointee && !isExplicit && !canBeAssumedSize) {
+    msg =
+        "Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;
   } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
       !isAssumedRank) {
     if (symbol.owner().IsDerivedType()) { // C745
@@ -1148,12 +1148,14 @@ void CheckHelper::CheckArraySpec(
     }
   } else if (canBeAssumedShape && !canBeDeferred) {
     msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
-  } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared) { // C833
-    msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
   } else if (isAssumedRank) { // C837
     msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
+  } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&
+      !isCrayPointee) { // C833
+    msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
   } else if (canBeImplied) {
-    if (!IsNamedConstant(symbol) && !isCUDAShared) { // C835, C836
+    if (!IsNamedConstant(symbol) && !isCUDAShared &&
+        !isCrayPointee) { // C835, C836
       msg = "Implied-shape array '%s' must be a named constant or a "
             "dummy argument"_err_en_US;
     }
@@ -1162,7 +1164,8 @@ void CheckHelper::CheckArraySpec(
       msg = "Named constant '%s' array must have constant or"
             " implied shape"_err_en_US;
     }
-  } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {
+  } else if (!isExplicit &&
+      !(IsAllocatableOrPointer(symbol) || isCrayPointee)) {
     if (symbol.owner().IsDerivedType()) { // C749
       msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
             " have explicit shape"_err_en_US;
@@ -2739,7 +2742,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       context_.SetError(symbol);
     }
   }
-  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+  if (symbol.has<ObjectEntityDetails>()) {
     if (isExplicitBindC && !symbol.owner().IsModule()) {
       messages_.Say(symbol.name(),
           "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
@@ -2762,7 +2765,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
             context_.SetError(symbol);
           }
         } else if ((isExplicitBindC || symbol.attrs().test(Attr::VALUE)) &&
-            !evaluate::IsExplicitShape(symbol) && !object->IsAssumedSize()) {
+            !evaluate::IsExplicitShape(symbol) && !IsAssumedSizeArray(symbol)) {
           SayWithDeclaration(symbol, symbol.name(),
               "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
           context_.SetError(symbol);
diff --git a/flang/lib/Semantics/check-namelist.cpp b/flang/lib/Semantics/check-namelist.cpp
index 630840a..b000e17 100644
--- a/flang/lib/Semantics/check-namelist.cpp
+++ b/flang/lib/Semantics/check-namelist.cpp
@@ -15,13 +15,10 @@ void NamelistChecker::Leave(const parser::NamelistStmt &nmlStmt) {
     if (const auto *nml{std::get<parser::Name>(x.t).symbol}) {
       for (const auto &nmlObjName : std::get<std::list<parser::Name>>(x.t)) {
         const auto *nmlObjSymbol{nmlObjName.symbol};
-        if (nmlObjSymbol && nmlObjSymbol->has<ObjectEntityDetails>()) {
-          const auto *symDetails{
-              std::get_if<ObjectEntityDetails>(&nmlObjSymbol->details())};
-          if (symDetails && symDetails->IsAssumedSize()) { // C8104
+        if (nmlObjSymbol) {
+          if (IsAssumedSizeArray(*nmlObjSymbol)) { // C8104
             context_.Say(nmlObjName.source,
-                "A namelist group object '%s' must not be"
-                " assumed-size"_err_en_US,
+                "A namelist group object '%s' must not be assumed-size"_err_en_US,
                 nmlObjSymbol->name());
           }
           if (nml->attrs().test(Attr::PUBLIC) &&