[flang] Fix classification of shape inquiries in specification exprs

[klausler]

Summary

In some contexts, including the motivating case of determining whether
the expressions that define the shape of a variable are "constant expressions"
in the sense of the Fortran standard, expression rewriting via Fold()
is not necessary, and should not be required.  The inquiry intrinsics LBOUND,
UBOUND, and SIZE work correctly now in specification expressions and are
classified correctly as being constant expressions (or not).  Getting this right
led to a fair amount of API clean-up as a consequence, including the
folding of shapes and TypeAndShape objects, and new APIs for shapes
that do not fold for those cases where folding isn't needed.  Further,
the symbol-testing predicate APIs in Evaluate/tools.h now all resolve any
associations of their symbols and work transparently on use-, host-, and
construct-association symbols; the tools used to resolve those associations have
been defined and documented more precisely, and their clients adjusted as needed.

flang/include/flang/Evaluate/characteristics.h

public:
   bool operator==(const TypeAndShape &) const;
   bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
 
   static std::optional<TypeAndShape> Characterize(
       const semantics::Symbol &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ObjectEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::ProcInterface &);
+      const semantics::ProcInterface &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::DeclTypeSpec &);
+      const semantics::DeclTypeSpec &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const ActualArgument &, FoldingContext &);
 
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
       const A &x, FoldingContext &context) {
     if (const auto *symbol{UnwrapWholeSymbolDataRef(x)}) {
       if (auto result{Characterize(*symbol, context)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
       if (auto shape{GetShape(context, x)}) {
         TypeAndShape result{*type, std::move(*shape)};
         if (type->category() == TypeCategory::Character) {
           if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
             if (auto length{chExpr->LEN()}) {
-              result.set_LEN(Fold(context, std::move(*length)));
+              result.set_LEN(std::move(*length));
             }
           }
         }
-        return result;
+        return std::move(result.Rewrite(context));
       }
     }
     return std::nullopt;
   }
+
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
       const std::optional<A> &x, FoldingContext &context) {
     if (x) {
       return Characterize(*x, context);
     } else {
       return std::nullopt;
     }
   }
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      const A *x, FoldingContext &context) {
-    if (x) {
-      return Characterize(*x, context);
+      const A *p, FoldingContext &context) {
+    if (p) {
+      return Characterize(*p, context);
     } else {
       return std::nullopt;
     }
   }
 
   DynamicType type() const { return type_; }
   TypeAndShape &set_type(DynamicType t) {
     type_ = t;
public:
   int Rank() const { return GetRank(shape_); }
   bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that,
       const char *thisIs = "pointer", const char *thatIs = "target",
       bool isElemental = false, bool thisIsDeferredShape = false,
       bool thatIsDeferredShape = false) const;
   std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(
       FoldingContext &) const;
 
+  // called by Fold() to rewrite in place
+  TypeAndShape &Rewrite(FoldingContext &);
+
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   static std::optional<TypeAndShape> Characterize(
       const semantics::AssocEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::ProcEntityDetails &);
-  void AcquireShape(const semantics::ObjectEntityDetails &, FoldingContext &);
+      const semantics::ProcEntityDetails &, FoldingContext &);
+  void AcquireShape(const semantics::ObjectEntityDetails &);
   void AcquireLEN();
 
 protected:
   DynamicType type_;
   std::optional<Expr<SubscriptInteger>> LEN_;
   Shape shape_;
   Attrs attrs_;
   int corank_{0};
struct Procedure {
 
   std::optional<FunctionResult> functionResult;
   DummyArguments dummyArguments;
   Attrs attrs;
 
 private:
   Procedure() {}
 };
-
 } // namespace Fortran::evaluate::characteristics
 #endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_

flang/include/flang/Evaluate/fold.h

 
 #include "common.h"
 #include "constant.h"
 #include "expression.h"
 #include "tools.h"
 #include "type.h"
 #include <variant>
 
+namespace Fortran::evaluate::characteristics {
+class TypeAndShape;
+}
+
 namespace Fortran::evaluate {
 
 using namespace Fortran::parser::literals;
 
 // Fold() rewrites an expression and returns it.  When the rewritten expression
 // is a constant, UnwrapConstantValue() and GetScalarConstantValue() below will
 // be able to extract it.
 // Note the rvalue reference argument: the rewrites are performed in place
 // for efficiency.
 template <typename T> Expr<T> Fold(FoldingContext &context, Expr<T> &&expr) {
   return Expr<T>::Rewrite(context, std::move(expr));
 }
 
-template <typename T>
-std::optional<Expr<T>> Fold(
-    FoldingContext &context, std::optional<Expr<T>> &&expr) {
-  if (expr) {
-    return Fold(context, std::move(*expr));
+characteristics::TypeAndShape Fold(
+    FoldingContext &, characteristics::TypeAndShape &&);
+
+template <typename A>
+std::optional<A> Fold(FoldingContext &context, std::optional<A> &&x) {
+  if (x) {
+    return Fold(context, std::move(*x));
   } else {
     return std::nullopt;
   }
 }
 
 // UnwrapConstantValue() isolates the known constant value of
 // an expression, if it has one.  It returns a pointer, which is
 // const-qualified when the expression is so.  The value can be

 template <typename A>
 std::optional<std::int64_t> ToInt64(const std::optional<A> &x) {
   if (x) {
     return ToInt64(*x);
   } else {
     return std::nullopt;
   }
 }
+
+template <typename A> std::optional<std::int64_t> ToInt64(const A *p) {
+  if (p) {
+    return ToInt64(*p);
+  } else {
+    return std::nullopt;
+  }
+}
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_FOLD_H_

flang/include/flang/Evaluate/shape.h

 using ExtentExpr = Expr<ExtentType>;
 using MaybeExtentExpr = std::optional<ExtentExpr>;
 using Shape = std::vector<MaybeExtentExpr>;
 
 bool IsImpliedShape(const Symbol &);
 bool IsExplicitShape(const Symbol &);
 
 // Conversions between various representations of shapes.
-Shape AsShape(const Constant<ExtentType> &);
-std::optional<Shape> AsShape(FoldingContext &, ExtentExpr &&);
-
 std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &);
 
 std::optional<Constant<ExtentType>> AsConstantShape(
     FoldingContext &, const Shape &);
 Constant<ExtentType> AsConstantShape(const ConstantSubscripts &);
 
 ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &);
 std::optional<ConstantSubscripts> AsConstantExtents(
     FoldingContext &, const Shape &);
 
 inline int GetRank(const Shape &s) { return static_cast<int>(s.size()); }
 
+Shape Fold(FoldingContext &, Shape &&);
+std::optional<Shape> Fold(FoldingContext &, std::optional<Shape> &&);
+
 template <typename A>
 std::optional<Shape> GetShape(FoldingContext &, const A &);
+template <typename A> std::optional<Shape> GetShape(const A &);
 
 // The dimension argument to these inquiries is zero-based,
 // unlike the DIM= arguments to many intrinsics.
+ExtentExpr GetLowerBound(const NamedEntity &, int dimension);
 ExtentExpr GetLowerBound(FoldingContext &, const NamedEntity &, int dimension);
+MaybeExtentExpr GetUpperBound(const NamedEntity &, int dimension);
 MaybeExtentExpr GetUpperBound(
     FoldingContext &, const NamedEntity &, int dimension);
+MaybeExtentExpr ComputeUpperBound(ExtentExpr &&lower, MaybeExtentExpr &&extent);
 MaybeExtentExpr ComputeUpperBound(
     FoldingContext &, ExtentExpr &&lower, MaybeExtentExpr &&extent);
+Shape GetLowerBounds(const NamedEntity &);
 Shape GetLowerBounds(FoldingContext &, const NamedEntity &);
+Shape GetUpperBounds(const NamedEntity &);
 Shape GetUpperBounds(FoldingContext &, const NamedEntity &);
+MaybeExtentExpr GetExtent(const NamedEntity &, int dimension);
 MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension);
 MaybeExtentExpr GetExtent(
+    const Subscript &, const NamedEntity &, int dimension);
+MaybeExtentExpr GetExtent(
     FoldingContext &, const Subscript &, const NamedEntity &, int dimension);
 
 // Compute an element count for a triplet or trip count for a DO.
-ExtentExpr CountTrips(FoldingContext &, ExtentExpr &&lower, ExtentExpr &&upper,
-    ExtentExpr &&stride);
-ExtentExpr CountTrips(FoldingContext &, const ExtentExpr &lower,
-    const ExtentExpr &upper, const ExtentExpr &stride);
-MaybeExtentExpr CountTrips(FoldingContext &, MaybeExtentExpr &&lower,
-    MaybeExtentExpr &&upper, MaybeExtentExpr &&stride);
+ExtentExpr CountTrips(
+    ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride);
+ExtentExpr CountTrips(
+    const ExtentExpr &lower, const ExtentExpr &upper, const ExtentExpr &stride);
+MaybeExtentExpr CountTrips(
+    MaybeExtentExpr &&lower, MaybeExtentExpr &&upper, MaybeExtentExpr &&stride);
 
 // Computes SIZE() == PRODUCT(shape)
 MaybeExtentExpr GetSize(Shape &&);
 
 // Utility predicate: does an expression reference any implied DO index?
 bool ContainsAnyImpliedDoIndex(const ExtentExpr &);
 
 class GetShapeHelper
     : public AnyTraverse<GetShapeHelper, std::optional<Shape>> {
 public:
   using Result = std::optional<Shape>;
   using Base = AnyTraverse<GetShapeHelper, Result>;
   using Base::operator();
-  explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{c} {}
+  GetShapeHelper() : Base{*this} {}
+  explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{&c} {}
 
-  Result operator()(const ImpliedDoIndex &) const { return Scalar(); }
-  Result operator()(const DescriptorInquiry &) const { return Scalar(); }
-  Result operator()(const TypeParamInquiry &) const { return Scalar(); }
-  Result operator()(const BOZLiteralConstant &) const { return Scalar(); }
+  Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); }
+  Result operator()(const DescriptorInquiry &) const { return ScalarShape(); }
+  Result operator()(const TypeParamInquiry &) const { return ScalarShape(); }
+  Result operator()(const BOZLiteralConstant &) const { return ScalarShape(); }
   Result operator()(const StaticDataObject::Pointer &) const {
-    return Scalar();
+    return ScalarShape();
+  }
+  Result operator()(const StructureConstructor &) const {
+    return ScalarShape();
   }
-  Result operator()(const StructureConstructor &) const { return Scalar(); }
 
   template <typename T> Result operator()(const Constant<T> &c) const {
-    return AsShape(c.SHAPE());
+    return ConstantShape(c.SHAPE());
   }
 
   Result operator()(const Symbol &) const;
   Result operator()(const Component &) const;
   Result operator()(const ArrayRef &) const;
   Result operator()(const CoarrayRef &) const;
   Result operator()(const Substring &) const;
   Result operator()(const ProcedureRef &) const;
 
   template <typename T>
   Result operator()(const ArrayConstructor<T> &aconst) const {
     return Shape{GetArrayConstructorExtent(aconst)};
   }
   template <typename D, typename R, typename LO, typename RO>
   Result operator()(const Operation<D, R, LO, RO> &operation) const {
     if (operation.right().Rank() > 0) {
       return (*this)(operation.right());
     } else {
       return (*this)(operation.left());
     }
   }
 
 private:
-  static Result Scalar() { return Shape{}; }
-  Shape CreateShape(int rank, NamedEntity &base) const {
-    Shape shape;
-    for (int dimension{0}; dimension < rank; ++dimension) {
-      shape.emplace_back(GetExtent(context_, base, dimension));
-    }
-    return shape;
-  }
+  static Result ScalarShape() { return Shape{}; }
+  static Shape ConstantShape(const Constant<ExtentType> &);
+  Result AsShape(ExtentExpr &&) const;
+  static Shape CreateShape(int rank, NamedEntity &);
+
   template <typename T>
   MaybeExtentExpr GetArrayConstructorValueExtent(
       const ArrayConstructorValue<T> &value) const {
     return std::visit(
         common::visitors{
             [&](const Expr<T> &x) -> MaybeExtentExpr {
-              if (std::optional<Shape> xShape{GetShape(context_, x)}) {
+              if (auto xShape{
+                      context_ ? GetShape(*context_, x) : GetShape(x)}) {
                 // Array values in array constructors get linearized.
                 return GetSize(std::move(*xShape));
               } else {
                 return std::nullopt;
               }
             },
             [&](const ImpliedDo<T> &ido) -> MaybeExtentExpr {
               // Don't be heroic and try to figure out triangular implied DO
               // nests.
               if (!ContainsAnyImpliedDoIndex(ido.lower()) &&
                   !ContainsAnyImpliedDoIndex(ido.upper()) &&
                   !ContainsAnyImpliedDoIndex(ido.stride())) {
                 if (auto nValues{GetArrayConstructorExtent(ido.values())}) {
                   return std::move(*nValues) *
-                      CountTrips(
-                          context_, ido.lower(), ido.upper(), ido.stride());
+                      CountTrips(ido.lower(), ido.upper(), ido.stride());
                 }
               }
               return std::nullopt;
             },
         },
         value.u);
   }
 
   template <typename T>
   MaybeExtentExpr GetArrayConstructorExtent(
       const ArrayConstructorValues<T> &values) const {
     ExtentExpr result{0};
     for (const auto &value : values) {
       if (MaybeExtentExpr n{GetArrayConstructorValueExtent(value)}) {
         result = std::move(result) + std::move(*n);
       } else {
         return std::nullopt;
       }
     }
     return result;
   }
 
-  FoldingContext &context_;
+  FoldingContext *context_{nullptr};
 };
 
 template <typename A>
 std::optional<Shape> GetShape(FoldingContext &context, const A &x) {
-  return GetShapeHelper{context}(x);
+  if (auto shape{GetShapeHelper{context}(x)}) {
+    return Fold(context, std::move(shape));
+  } else {
+    return std::nullopt;
+  }
+}
+
+template <typename A> std::optional<Shape> GetShape(const A &x) {
+  return GetShapeHelper{}(x);
+}
+
+template <typename A>
+std::optional<Shape> GetShape(FoldingContext *context, const A &x) {
+  if (context) {
+    return GetShape(*context, x);
+  } else {
+    return GetShapeHelper{}(x);
+  }
 }
 
 template <typename A>
 std::optional<Constant<ExtentType>> GetConstantShape(
     FoldingContext &context, const A &x) {
   if (auto shape{GetShape(context, x)}) {
     return AsConstantShape(context, *shape);
   } else {

flang/include/flang/Evaluate/tools.h

 std::optional<DataRef> ExtractDataRef(
     const std::optional<A> &x, bool intoSubstring = false) {
   if (x) {
     return ExtractDataRef(*x, intoSubstring);
   } else {
     return std::nullopt;
   }
 }
+template <typename A>
+std::optional<DataRef> ExtractDataRef(const A *p, bool intoSubstring = false) {
+  if (p) {
+    return ExtractDataRef(*p, intoSubstring);
+  } else {
+    return std::nullopt;
+  }
+}
 std::optional<DataRef> ExtractSubstringBase(const Substring &);
 
 // Predicate: is an expression is an array element reference?
 template <typename T>
 bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = false) {
   if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
     const DataRef *ref{&*dataRef};
     while (const Component * component{std::get_if<Component>(&ref->u)}) {
template <typename A> SymbolVector GetSymbolVector(const A &x) {
   return GetSymbolVectorHelper{}(x);
 }
 
 // GetLastTarget() returns the rightmost symbol in an object designator's
 // SymbolVector that has the POINTER or TARGET attribute, or a null pointer
 // when none is found.
 const Symbol *GetLastTarget(const SymbolVector &);
 
-// Resolves any whole ASSOCIATE(B=>A) associations, then returns GetUltimate()
-const Symbol &ResolveAssociations(const Symbol &);
-
 // Collects all of the Symbols in an expression
 template <typename A> semantics::SymbolSet CollectSymbols(const A &);
 extern template semantics::SymbolSet CollectSymbols(const Expr<SomeType> &);
 extern template semantics::SymbolSet CollectSymbols(const Expr<SomeInteger> &);
 extern template semantics::SymbolSet CollectSymbols(
     const Expr<SubscriptInteger> &);
 
 // Predicate: does a variable contain a vector-valued subscript (not a triplet)?

 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 class Scope;
 
 // These functions are used in Evaluate so they are defined here rather than in
 // Semantics to avoid a link-time dependency on Semantics.
+// All of these apply GetUltimate() or ResolveAssociations() to their arguments.
 
 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
 bool IsFunction(const Symbol &);
 bool IsProcedure(const Symbol &);
 bool IsProcedurePointer(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);
 bool IsFunctionResult(const Symbol &);
 bool IsKindTypeParameter(const Symbol &);
 bool IsLenTypeParameter(const Symbol &);
 
-// Follow use, host, and construct assocations to a variable, if any.
-const Symbol *GetAssociationRoot(const Symbol &);
-Symbol *GetAssociationRoot(Symbol &);
+// ResolveAssociations() traverses use associations and host associations
+// like GetUltimate(), but also resolves through whole variable associations
+// with ASSOCIATE(x => y) and related constructs.  GetAssociationRoot()
+// applies ResolveAssociations() and then, in the case of resolution to
+// a construct association with part of a variable that does not involve a
+// vector subscript, returns the first symbol of that variable instead
+// of the construct entity.
+// (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
+// while GetAssociationRoot(x) returns y.)
+const Symbol &ResolveAssociations(const Symbol &);
+const Symbol &GetAssociationRoot(const Symbol &);
+
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);
 int CountNonConstantLenParameters(const DerivedTypeSpec &);
 const Symbol &GetUsedModule(const UseDetails &);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/include/flang/Evaluate/type.h

 template <typename T>
 constexpr bool IsLengthlessIntrinsicType{
     common::HasMember<T, LengthlessIntrinsicTypes>};
 
 // Represents a type of any supported kind within a particular category.
 template <TypeCategory CATEGORY> struct SomeKind {
   static constexpr TypeCategory category{CATEGORY};
   constexpr bool operator==(const SomeKind &) const { return true; }
+  static std::string AsFortran() {
+    return "Some"s + common::EnumToString(category);
+  }
 };
 
 using NumericCategoryTypes = std::tuple<SomeKind<TypeCategory::Integer>,
     SomeKind<TypeCategory::Real>, SomeKind<TypeCategory::Complex>>;
 using AllIntrinsicCategoryTypes = std::tuple<SomeKind<TypeCategory::Integer>,
     SomeKind<TypeCategory::Real>, SomeKind<TypeCategory::Complex>,
     SomeKind<TypeCategory::Character>, SomeKind<TypeCategory::Logical>>;
 
 // Represents a completely generic type (or, for Expr<SomeType>, a typeless
 // value like a BOZ literal or NULL() pointer).
-struct SomeType {};
+struct SomeType {
+  static std::string AsFortran() { return "SomeType"s; }
+};
 
 class StructureConstructor;
 
 // Represents any derived type, polymorphic or not, as well as CLASS(*).
 template <> class SomeKind<TypeCategory::Derived> {
 public:
   static constexpr TypeCategory category{TypeCategory::Derived};
   using Scalar = StructureConstructor;

flang/include/flang/Semantics/tools.h

 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name);
 // Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV
 bool IsTeamType(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 *);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
+// Does a non-PARAMETER symbol have explicit initialization with =value or
+// =>target in its declaration, or optionally in a DATA statement? (Being
+// ALLOCATABLE or having a derived type with default component initialization
+// doesn't count; it must be a variable initialization that implies the SAVE
+// attribute, or a derived type component default value.)
+bool IsStaticallyInitialized(const Symbol &, bool ignoreDATAstatements = false);
+// Is the symbol explicitly or implicitly initialized in any way?
 bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false,
     const Symbol *derivedType = nullptr);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
 bool IsAutomatic(const Symbol &);
 bool HasAlternateReturns(const Symbol &);
 bool InCommonBlock(const Symbol &);
 

flang/lib/Evaluate/characteristics.cpp

bool ShapesAreCompatible(const Shape &x, const Shape &y) {
   return true;
 }
 
 bool TypeAndShape::operator==(const TypeAndShape &that) const {
   return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
       attrs_ == that.attrs_ && corank_ == that.corank_;
 }
 
+TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
+  LEN_ = Fold(context, std::move(LEN_));
+  shape_ = Fold(context, std::move(shape_));
+  return *this;
+}
+
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
   return std::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
             auto result{Characterize(object, context)};
             if (result &&
                 result->type().category() == TypeCategory::Character) {
               if (auto len{DataRef{symbol}.LEN()}) {
                 result->set_LEN(Fold(context, std::move(*len)));
               }
             }
             return result;
           },
           [&](const semantics::ProcEntityDetails &proc) {
             const semantics::ProcInterface &interface{proc.interface()};
             if (interface.type()) {
-              return Characterize(*interface.type());
+              return Characterize(*interface.type(), context);
             } else if (interface.symbol()) {
               return Characterize(*interface.symbol(), context);
             } else {
               return std::optional<TypeAndShape>{};
             }
           },
           [&](const semantics::TypeParamDetails &tp) {
             if (auto type{DynamicType::From(tp.type())}) {
               return std::optional<TypeAndShape>{std::move(*type)};
             } else {
               return std::optional<TypeAndShape>{};
             }
           },
-          [&](const semantics::UseDetails &use) {
-            return Characterize(use.symbol(), context);
-          },
-          [&](const semantics::HostAssocDetails &assoc) {
-            return Characterize(assoc.symbol(), context);
-          },
           [&](const semantics::AssocEntityDetails &assoc) {
             return Characterize(assoc, context);
           },
           [](const auto &) { return std::optional<TypeAndShape>{}; },
       },
-      symbol.details());
+      // GetUltimate() used here, not ResolveAssociations(), because
+      // we need the type/rank of an associate entity from TYPE IS,
+      // CLASS IS, or RANK statement.
+      symbol.GetUltimate().details());
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::ObjectEntityDetails &object, FoldingContext &context) {
   if (auto type{DynamicType::From(object.type())}) {
     TypeAndShape result{std::move(*type)};
-    result.AcquireShape(object, context);
-    return result;
+    result.AcquireShape(object);
+    return Fold(context, std::move(result));
   } else {
     return std::nullopt;
   }
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
+  std::optional<TypeAndShape> result;
   if (auto type{DynamicType::From(assoc.type())}) {
-    if (auto shape{GetShape(context, assoc.expr())}) {
-      TypeAndShape result{std::move(*type), std::move(*shape)};
-      if (type->category() == TypeCategory::Character) {
-        if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
-          if (auto len{chExpr->LEN()}) {
-            result.set_LEN(Fold(context, std::move(*len)));
-          }
-        }
-      }
-      return std::move(result);
-    }
-  }
-  return std::nullopt;
+    if (auto rank{assoc.rank()}) {
+      if (*rank >= 0 && *rank <= common::maxRank) {
+        result = TypeAndShape{std::move(*type), Shape(*rank)};
+      }
+    } else if (auto shape{GetShape(context, assoc.expr())}) {
+      result = TypeAndShape{std::move(*type), std::move(*shape)};
+    }
+    if (result && type->category() == TypeCategory::Character) {
+          result->set_LEN(std::move(*len));
+  return Fold(context, std::move(result));
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::DeclTypeSpec &spec) {
+    const semantics::DeclTypeSpec &spec, FoldingContext &context) {
   if (auto type{DynamicType::From(spec)}) {
-    return TypeAndShape{std::move(*type)};
+    return Fold(context, TypeAndShape{std::move(*type)});
   } else {
     return std::nullopt;
   }
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const ActualArgument &arg, FoldingContext &context) {
   return Characterize(arg.UnwrapExpr(), context);
if (auto elementBytes{
             type_.MeasureSizeInBytes(foldingContext, GetRank(shape_) > 0)}) {
       return Fold(
           foldingContext, std::move(*elements) * std::move(*elementBytes));
     }
   }
   return std::nullopt;
 }
 
-void TypeAndShape::AcquireShape(
-    const semantics::ObjectEntityDetails &object, FoldingContext &context) {
+void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
   CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
   corank_ = object.coshape().Rank();
   if (object.IsAssumedRank()) {
     attrs_.set(Attr::AssumedRank);
     return;
   }
   if (object.IsAssumedShape()) {
     attrs_.set(Attr::AssumedShape);
void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
   }
   for (const semantics::ShapeSpec &dim : object.shape()) {
     if (dim.ubound().GetExplicit()) {
       Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()};
       if (auto lbound{dim.lbound().GetExplicit()}) {
         extent =
             std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
       }
-      shape_.emplace_back(Fold(context, std::move(extent)));
+      shape_.emplace_back(std::move(extent));
     } else {
       shape_.push_back(std::nullopt);
     }
   }
 }
 
 void TypeAndShape::AcquireLEN() {
   if (type_.category() == TypeCategory::Character) {
for (int j{0}; j < argCount; ++j) {
     }
   }
   return true;
 }
 
 std::optional<Procedure> Procedure::Characterize(
     const semantics::Symbol &original, FoldingContext &context) {
   Procedure result;
-  const auto &symbol{ResolveAssociations(original)};
+  const auto &symbol{original.GetUltimate()};
   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
       {
           {semantics::Attr::PURE, Procedure::Attr::Pure},
           {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
       });
   if (result.attrs.test(Attr::Elemental) &&
       !symbol.attrs().test(semantics::Attr::IMPURE)) {
return std::visit(
       },
       symbol.details());
 }
 
 std::optional<Procedure> Procedure::Characterize(
     const ProcedureDesignator &proc, FoldingContext &context) {
   if (const auto *symbol{proc.GetSymbol()}) {
     if (auto result{characteristics::Procedure::Characterize(
-            ResolveAssociations(*symbol), context)}) {
+            symbol->GetUltimate(), context)}) {
       return result;
     }
   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
     return intrinsic->characteristics.value();
   }
   return std::nullopt;
 }
 

flang/lib/Evaluate/check-expression.cpp

 // the expression may reference derived type kind parameters whose values
 // are not yet known.
 class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
 public:
   using Base = AllTraverse<IsConstantExprHelper, true>;
   IsConstantExprHelper() : Base{*this} {}
   using Base::operator();
 
+  // A missing expression is not considered to be constant.
+  template <typename A> bool operator()(const std::optional<A> &x) const {
+    return x && (*this)(*x);
+  }
+
   bool operator()(const TypeParamInquiry &inq) const {
     return semantics::IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{symbol.GetUltimate()};
     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
         IsInitialProcedureTarget(ultimate);
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
-  template <typename T> bool operator()(const FunctionRef<T> &call) const {
-    if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
-      // kind is always a constant, and we avoid cascading errors by calling
-      // invalid calls to intrinsics constant
-      return intrinsic->name == "kind" ||
-          intrinsic->name == IntrinsicProcTable::InvalidName;
-      // TODO: other inquiry intrinsics
-    } else {
-      return false;
-    }
-  }
+  bool operator()(const ProcedureRef &) const;
   bool operator()(const StructureConstructor &constructor) const {
     for (const auto &[symRef, expr] : constructor) {
       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
         return false;
       }
     }
     return true;
   }
   bool operator()(const Component &component) const {
     return (*this)(component.base());
   }
   // Forbid integer division by zero in constants.
   template <int KIND>
   bool operator()(
       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
     using T = Type<TypeCategory::Integer, KIND>;
     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
       return !divisor->IsZero() && (*this)(division.left());
     } else {
       return false;
     }
   }
 
   bool operator()(const Constant<SomeDerived> &) const { return true; }
+  bool operator()(const DescriptorInquiry &) const { return false; }
 
 private:
   bool IsConstantStructureConstructorComponent(
-      const Symbol &component, const Expr<SomeType> &expr) const {
-    if (IsAllocatable(component)) {
-      return IsNullPointer(expr);
-    } else if (IsPointer(component)) {
-      return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
-          IsInitialProcedureTarget(expr);
-    } else {
-      return (*this)(expr);
-    }
-  }
-};
+      const Symbol &, const Expr<SomeType> &) const;
+  bool IsConstantExprShape(const Shape &) const;
+};
+
+bool IsConstantExprHelper::IsConstantStructureConstructorComponent(
+
+bool IsConstantExprHelper::operator()(const ProcedureRef &call) const {
+  // LBOUND, UBOUND, and SIZE with DIM= arguments will have been reritten
+  // into DescriptorInquiry operations.
+  if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
+    if (intrinsic->name == "kind" ||
+        intrinsic->name == IntrinsicProcTable::InvalidName) {
+      // kind is always a constant, and we avoid cascading errors by considering
+      // invalid calls to intrinsics to be constant
+      return true;
+    } else if (intrinsic->name == "lbound" && call.arguments().size() == 1) {
+      // LBOUND(x) without DIM=
+      auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
+      return base && IsConstantExprShape(GetLowerBounds(*base));
+    } else if (intrinsic->name == "ubound" && call.arguments().size() == 1) {
+      // UBOUND(x) without DIM=
+      auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
+      return base && IsConstantExprShape(GetUpperBounds(*base));
+    } else if (intrinsic->name == "shape") {
+      auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
+      return shape && IsConstantExprShape(*shape);
+    } else if (intrinsic->name == "size" && call.arguments().size() == 1) {
+      // SIZE(x) without DIM
+      auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
+      return shape && IsConstantExprShape(*shape);
+    }
+    // TODO: STORAGE_SIZE
+  }
+  return false;
+}
+
+bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const {
+  for (const auto &extent : shape) {
+    if (!(*this)(extent)) {
+      return false;
+    }
+  }
+  return true;
+}
 
 template <typename A> bool IsConstantExpr(const A &x) {
   return IsConstantExprHelper{}(x);
 }
 template bool IsConstantExpr(const Expr<SomeType> &);
 template bool IsConstantExpr(const Expr<SomeInteger> &);
 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
 template bool IsConstantExpr(const StructureConstructor &);

flang/lib/Evaluate/fold.cpp

 //===-- lib/Evaluate/fold.cpp ---------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/fold.h"
 #include "fold-implementation.h"
+#include "flang/Evaluate/characteristics.h"
 
 namespace Fortran::evaluate {
 
+characteristics::TypeAndShape Fold(
+    FoldingContext &context, characteristics::TypeAndShape &&x) {
+  x.Rewrite(context);
+  return std::move(x);
+}
+
 std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
     FoldingContext &context, Subscript &ss, const NamedEntity &base, int dim) {
   ss = FoldOperation(context, std::move(ss));
   return std::visit(
       common::visitors{
           [](IndirectSubscriptIntegerExpr &expr)
               -> std::optional<Constant<SubscriptInteger>> {
             if (const auto *constant{

flang/lib/Evaluate/intrinsics.cpp

std::optional<SpecificCall> IntrinsicInterface::Match(
   std::optional<int> sameDummyArg;
 
   for (std::size_t j{0}; j < dummies; ++j) {
     const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
     if (const auto &arg{rearranged[j]}) {
       if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
         auto dc{characteristics::DummyArgument::FromActual(
             std::string{d.keyword}, *expr, context)};
-        CHECK(dc);
+        if (!dc) {
+          common::die("INTERNAL: could not characterize intrinsic function "
+                      "actual argument '%s'",
+              expr->AsFortran().c_str());
+          return std::nullopt;
+        }
         dummyArgs.emplace_back(std::move(*dc));
         if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
           sameDummyArg = j;
         }
       } else {
         CHECK(arg->GetAssumedTypeDummy());
         dummyArgs.emplace_back(std::string{d.keyword},
             characteristics::DummyDataObject{DynamicType::AssumedType()});

flang/lib/Evaluate/shape.cpp

 #include "flang/Parser/message.h"
 #include "flang/Semantics/symbol.h"
 #include <functional>
 
 using namespace std::placeholders; // _1, _2, &c. for std::bind()
 
 namespace Fortran::evaluate {
 
-bool IsImpliedShape(const Symbol &symbol0) {
-  const Symbol &symbol{ResolveAssociations(symbol0)};
+bool IsImpliedShape(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
   const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
-  return symbol.attrs().test(semantics::Attr::PARAMETER) && details &&
+  return details && symbol.attrs().test(semantics::Attr::PARAMETER) &&
       details->shape().IsImpliedShape();
 }
 
-bool IsExplicitShape(const Symbol &symbol0) {
-  const Symbol &symbol{ResolveAssociations(symbol0)};
+bool IsExplicitShape(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     const auto &shape{details->shape()};
-    return shape.Rank() == 0 || shape.IsExplicitShape(); // even if scalar
+    return shape.Rank() == 0 ||
+        shape.IsExplicitShape(); // true when scalar, too
   } else {
-    return false;
+    return symbol
+        .has<semantics::AssocEntityDetails>(); // exprs have explicit shape
   }
 }
 
-Shape AsShape(const Constant<ExtentType> &arrayConstant) {
+Shape GetShapeHelper::ConstantShape(const Constant<ExtentType> &arrayConstant) {
   CHECK(arrayConstant.Rank() == 1);
   Shape result;
   std::size_t dimensions{arrayConstant.size()};
   for (std::size_t j{0}; j < dimensions; ++j) {
     Scalar<ExtentType> extent{arrayConstant.values().at(j)};
-    result.emplace_back(MaybeExtentExpr{ExtentExpr{extent}});
+    result.emplace_back(MaybeExtentExpr{ExtentExpr{std::move(extent)}});
   }
   return result;
 }
 
-std::optional<Shape> AsShape(FoldingContext &context, ExtentExpr &&arrayExpr) {
-  // Flatten any array expression into an array constructor if possible.
-  arrayExpr = Fold(context, std::move(arrayExpr));
+auto GetShapeHelper::AsShape(ExtentExpr &&arrayExpr) const -> Result {
+  if (context_) {
+    arrayExpr = Fold(*context_, std::move(arrayExpr));
+  }
   if (const auto *constArray{UnwrapConstantValue<ExtentType>(arrayExpr)}) {
-    return AsShape(*constArray);
+    return ConstantShape(*constArray);
   }
   if (auto *constructor{UnwrapExpr<ArrayConstructor<ExtentType>>(arrayExpr)}) {
     Shape result;
     for (auto &value : *constructor) {
       if (auto *expr{std::get_if<ExtentExpr>(&value.u)}) {
         if (expr->Rank() == 0) {
           result.emplace_back(std::move(*expr));
           continue;
         }
       }
       return std::nullopt;
     }
     return result;
   }
   return std::nullopt;
 }
 
+Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
+  Shape shape;
+  for (int dimension{0}; dimension < rank; ++dimension) {
+    shape.emplace_back(GetExtent(base, dimension));
+  }
+  return shape;
+}
+
 std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
   ArrayConstructorValues<ExtentType> values;
   for (const auto &dim : shape) {
     if (dim) {
       values.Push(common::Clone(*dim));
     } else {
       return std::nullopt;
     }
std::optional<ConstantSubscripts> AsConstantExtents(
     FoldingContext &context, const Shape &shape) {
   if (auto shapeConstant{AsConstantShape(context, shape)}) {
     return AsConstantExtents(*shapeConstant);
   } else {
     return std::nullopt;
   }
 }
 
-static ExtentExpr ComputeTripCount(FoldingContext &context, ExtentExpr &&lower,
-    ExtentExpr &&upper, ExtentExpr &&stride) {
+Shape Fold(FoldingContext &context, Shape &&shape) {
+  for (auto &dim : shape) {
+    dim = Fold(context, std::move(dim));
+  }
+  return std::move(shape);
+}
+
+std::optional<Shape> Fold(
+    FoldingContext &context, std::optional<Shape> &&shape) {
+  if (shape) {
+    return Fold(context, std::move(*shape));
+  } else {
+    return std::nullopt;
+  }
+}
+
+static ExtentExpr ComputeTripCount(
+    ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
   ExtentExpr strideCopy{common::Clone(stride)};
   ExtentExpr span{
       (std::move(upper) - std::move(lower) + std::move(strideCopy)) /
       std::move(stride)};
-  ExtentExpr extent{
+  return ExtentExpr{
       Extremum<ExtentType>{Ordering::Greater, std::move(span), ExtentExpr{0}}};
-  return Fold(context, std::move(extent));
 }
 
-ExtentExpr CountTrips(FoldingContext &context, ExtentExpr &&lower,
-    ExtentExpr &&upper, ExtentExpr &&stride) {
+ExtentExpr CountTrips(
+    ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
   return ComputeTripCount(
-      context, std::move(lower), std::move(upper), std::move(stride));
+      std::move(lower), std::move(upper), std::move(stride));
 }
 
-ExtentExpr CountTrips(FoldingContext &context, const ExtentExpr &lower,
-    const ExtentExpr &upper, const ExtentExpr &stride) {
-  return ComputeTripCount(context, common::Clone(lower), common::Clone(upper),
-      common::Clone(stride));
+ExtentExpr CountTrips(const ExtentExpr &lower, const ExtentExpr &upper,
+    const ExtentExpr &stride) {
+  return ComputeTripCount(
+      common::Clone(lower), common::Clone(upper), common::Clone(stride));
 }
 
-MaybeExtentExpr CountTrips(FoldingContext &context, MaybeExtentExpr &&lower,
-    MaybeExtentExpr &&upper, MaybeExtentExpr &&stride) {
+MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,
+    MaybeExtentExpr &&stride) {
   std::function<ExtentExpr(ExtentExpr &&, ExtentExpr &&, ExtentExpr &&)> bound{
-      std::bind(ComputeTripCount, context, _1, _2, _3)};
+      std::bind(ComputeTripCount, _1, _2, _3)};
   return common::MapOptional(
       std::move(bound), std::move(lower), std::move(upper), std::move(stride));
 }
 
 MaybeExtentExpr GetSize(Shape &&shape) {
   ExtentExpr extent{1};
   for (auto &&dim : std::move(shape)) {
     if (dim) {

 // Determines lower bound on a dimension.  This can be other than 1 only
 // for a reference to a whole array object or component. (See LBOUND, 16.9.109).
 // ASSOCIATE construct entities may require tranversal of their referents.
 class GetLowerBoundHelper : public Traverse<GetLowerBoundHelper, ExtentExpr> {
 public:
   using Result = ExtentExpr;
   using Base = Traverse<GetLowerBoundHelper, ExtentExpr>;
   using Base::operator();
-  GetLowerBoundHelper(FoldingContext &c, int d)
-      : Base{*this}, context_{c}, dimension_{d} {}
+  explicit GetLowerBoundHelper(int d) : Base{*this}, dimension_{d} {}
   static ExtentExpr Default() { return ExtentExpr{1}; }
   static ExtentExpr Combine(Result &&, Result &&) { return Default(); }
   ExtentExpr operator()(const Symbol &);
   ExtentExpr operator()(const Component &);
 
 private:
-  FoldingContext &context_;
   int dimension_;
 };
 
 auto GetLowerBoundHelper::operator()(const Symbol &symbol0) -> Result {
   const Symbol &symbol{symbol0.GetUltimate()};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int j{0};
     for (const auto &shapeSpec : details->shape()) {
       if (j++ == dimension_) {
         if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
-          return Fold(context_, common::Clone(*bound));
+          return *bound;
         } else if (IsDescriptor(symbol)) {
           return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
               DescriptorInquiry::Field::LowerBound, dimension_}};
         } else {
           break;
         }
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
     return (*this)(assoc->expr());
   }
   return Default();
 }
 
 auto GetLowerBoundHelper::operator()(const Component &component) -> Result {
   if (component.base().Rank() == 0) {
     const Symbol &symbol{component.GetLastSymbol().GetUltimate()};
     if (const auto *details{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
       int j{0};
       for (const auto &shapeSpec : details->shape()) {
         if (j++ == dimension_) {
           if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
-            return Fold(context_, common::Clone(*bound));
+            return *bound;
           } else if (IsDescriptor(symbol)) {
             return ExtentExpr{
                 DescriptorInquiry{NamedEntity{common::Clone(component)},
                     DescriptorInquiry::Field::LowerBound, dimension_}};
           } else {
             break;
           }
         }
       }
     }
   }
   return Default();
 }
 
+ExtentExpr GetLowerBound(const NamedEntity &base, int dimension) {
+  return GetLowerBoundHelper{dimension}(base);
+}
+
 ExtentExpr GetLowerBound(
     FoldingContext &context, const NamedEntity &base, int dimension) {
-  return GetLowerBoundHelper{context, dimension}(base);
+  return Fold(context, GetLowerBound(base, dimension));
+}
+
+Shape GetLowerBounds(const NamedEntity &base) {
+  Shape result;
+  int rank{base.Rank()};
+  for (int dim{0}; dim < rank; ++dim) {
+    result.emplace_back(GetLowerBound(base, dim));
+  }
+  return result;
 }
 
 Shape GetLowerBounds(FoldingContext &context, const NamedEntity &base) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
     result.emplace_back(GetLowerBound(context, base, dim));
   }
   return result;
 }
 
-MaybeExtentExpr GetExtent(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
   CHECK(dimension >= 0);
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     if (IsImpliedShape(symbol)) {
-      Shape shape{GetShape(context, symbol).value()};
+      Shape shape{GetShape(symbol).value()};
       return std::move(shape.at(dimension));
     }
     int j{0};
     for (const auto &shapeSpec : details->shape()) {
       if (j++ == dimension) {
         if (shapeSpec.ubound().isExplicit()) {
           if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
             if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
-              return Fold(context,
-                  common::Clone(ubound.value()) -
-                      common::Clone(lbound.value()) + ExtentExpr{1});
+              return common::Clone(ubound.value()) -
+                  common::Clone(lbound.value()) + ExtentExpr{1};
             } else {
-              return Fold(context, common::Clone(ubound.value()));
+              return ubound.value();
             }
           }
         } else if (details->IsAssumedSize() && j == symbol.Rank()) {
           return std::nullopt;
         } else if (semantics::IsDescriptor(symbol)) {
           return ExtentExpr{DescriptorInquiry{
               NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
         }
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto shape{GetShape(context, assoc->expr())}) {
+    if (auto shape{GetShape(assoc->expr())}) {
       if (dimension < static_cast<int>(shape->size())) {
         return std::move(shape->at(dimension));
       }
     }
   }
   return std::nullopt;
 }
 
-MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
-    const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(
+    FoldingContext &context, const NamedEntity &base, int dimension) {
+  return Fold(context, GetExtent(base, dimension));
+}
+
+MaybeExtentExpr GetExtent(
+    const Subscript &subscript, const NamedEntity &base, int dimension) {
   return std::visit(
       common::visitors{
           [&](const Triplet &triplet) -> MaybeExtentExpr {
             MaybeExtentExpr upper{triplet.upper()};
             if (!upper) {
-              upper = GetUpperBound(context, base, dimension);
+              upper = GetUpperBound(base, dimension);
             }
             MaybeExtentExpr lower{triplet.lower()};
             if (!lower) {
-              lower = GetLowerBound(context, base, dimension);
+              lower = GetLowerBound(base, dimension);
             }
-            return CountTrips(context, std::move(lower), std::move(upper),
+            return CountTrips(std::move(lower), std::move(upper),
                 MaybeExtentExpr{triplet.stride()});
           },
           [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
-            if (auto shape{GetShape(context, subs.value())}) {
+            if (auto shape{GetShape(subs.value())}) {
               if (GetRank(*shape) > 0) {
                 CHECK(GetRank(*shape) == 1); // vector-valued subscript
                 return std::move(shape->at(0));
               }
             }
             return std::nullopt;
           },
       },
       subscript.u);
 }
 
+MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
+    const NamedEntity &base, int dimension) {
+  return Fold(context, GetExtent(subscript, base, dimension));
+}
+
 MaybeExtentExpr ComputeUpperBound(
-    FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
+    ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   if (extent) {
-    return Fold(context, std::move(*extent) - std::move(lower) + ExtentExpr{1});
+    return std::move(*extent) - std::move(lower) + ExtentExpr{1};
   } else {
     return std::nullopt;
   }
 }
 
-MaybeExtentExpr GetUpperBound(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+MaybeExtentExpr ComputeUpperBound(
+    FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
+  return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
+}
+
+MaybeExtentExpr GetUpperBound(const NamedEntity &base, int dimension) {
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int j{0};
     for (const auto &shapeSpec : details->shape()) {
       if (j++ == dimension) {
         if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
-          return Fold(context, common::Clone(*bound));
+          return *bound;
         } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
           break;
         } else {
-          return ComputeUpperBound(context,
-              GetLowerBound(context, base, dimension),
-              GetExtent(context, base, dimension));
+          return ComputeUpperBound(
+              GetLowerBound(base, dimension), GetExtent(base, dimension));
         }
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto shape{GetShape(context, assoc->expr())}) {
+    if (auto shape{GetShape(assoc->expr())}) {
       if (dimension < static_cast<int>(shape->size())) {
-        return ComputeUpperBound(context,
-            GetLowerBound(context, base, dimension),
-            std::move(shape->at(dimension)));
+        return ComputeUpperBound(
+            GetLowerBound(base, dimension), std::move(shape->at(dimension)));
       }
     }
   }
   return std::nullopt;
 }
 
-Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) {
+MaybeExtentExpr GetUpperBound(
+    FoldingContext &context, const NamedEntity &base, int dimension) {
+  return Fold(context, GetUpperBound(base, dimension));
+}
+
+Shape GetUpperBounds(const NamedEntity &base) {
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     Shape result;
     int dim{0};
     for (const auto &shapeSpec : details->shape()) {
       if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
-        result.emplace_back(Fold(context, common::Clone(*bound)));
+        result.push_back(*bound);
       } else if (details->IsAssumedSize()) {
         CHECK(dim + 1 == base.Rank());
         result.emplace_back(std::nullopt); // UBOUND folding replaces with -1
       } else {
-        result.emplace_back(ComputeUpperBound(context,
-            GetLowerBound(context, base, dim), GetExtent(context, base, dim)));
+        result.emplace_back(
+            ComputeUpperBound(GetLowerBound(base, dim), GetExtent(base, dim)));
       }
       ++dim;
     }
     CHECK(GetRank(result) == symbol.Rank());
     return result;
   } else {
-    return std::move(GetShape(context, base).value());
+    return std::move(GetShape(symbol).value());
   }
 }
 
+Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) {
+  return Fold(context, GetUpperBounds(base));
+}
+
 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
   return std::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
             if (IsImpliedShape(symbol)) {
               return (*this)(object.init());
             } else {
               int n{object.shape().Rank()};
               NamedEntity base{symbol};
               return Result{CreateShape(n, base)};
             }
           },
           [](const semantics::EntityDetails &) {
-            return Scalar(); // no dimensions seen
+            return ScalarShape(); // no dimensions seen
           },
           [&](const semantics::ProcEntityDetails &proc) {
             if (const Symbol * interface{proc.interface().symbol()}) {
               return (*this)(*interface);
             } else {
-              return Scalar();
+              return ScalarShape();
             }
           },
           [&](const semantics::AssocEntityDetails &assoc) {
             if (!assoc.rank()) {
               return (*this)(assoc.expr());
             } else {
               int n{assoc.rank().value()};
               NamedEntity base{symbol};
return std::visit(
             return (*this)(binding.symbol());
           },
           [&](const semantics::UseDetails &use) {
             return (*this)(use.symbol());
           },
           [&](const semantics::HostAssocDetails &assoc) {
             return (*this)(assoc.symbol());
           },
-          [](const semantics::TypeParamDetails &) { return Scalar(); },
+          [](const semantics::TypeParamDetails &) { return ScalarShape(); },
           [](const auto &) { return Result{}; },
       },
       symbol.details());
 }
 
 auto GetShapeHelper::operator()(const Component &component) const -> Result {
   const Symbol &symbol{component.GetLastSymbol()};
   int rank{symbol.Rank()};

 }
 
 auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
   Shape shape;
   int dimension{0};
   const NamedEntity &base{arrayRef.base()};
   for (const Subscript &ss : arrayRef.subscript()) {
     if (ss.Rank() > 0) {
-      shape.emplace_back(GetExtent(context_, ss, base, dimension));
+      shape.emplace_back(GetExtent(ss, base, dimension));
     }
     ++dimension;
   }
   if (shape.empty()) {
     if (const Component * component{base.UnwrapComponent()}) {
       return (*this)(component->base());
     }
   }
   return shape;
 }
 
 auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
   NamedEntity base{coarrayRef.GetBase()};
   if (coarrayRef.subscript().empty()) {
     return (*this)(base);
   } else {
     Shape shape;
     int dimension{0};
     for (const Subscript &ss : coarrayRef.subscript()) {
       if (ss.Rank() > 0) {
-        shape.emplace_back(GetExtent(context_, ss, base, dimension));
+        shape.emplace_back(GetExtent(ss, base, dimension));
       }
       ++dimension;
     }
     return shape;
   }
 }
 
 auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
   return (*this)(substring.parent());
 }
 
 auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
   if (call.Rank() == 0) {
-    return Scalar();
+    return ScalarShape();
   } else if (call.IsElemental()) {
     for (const auto &arg : call.arguments()) {
       if (arg && arg->Rank() > 0) {
         return (*this)(*arg);
       }
     }
-    return Scalar();
+    return ScalarShape();
   } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
     return (*this)(*symbol);
   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
         intrinsic->name == "ubound") {
       // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
       const auto *expr{call.arguments().front().value().UnwrapExpr()};
       CHECK(expr);
if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
         }
       }
     } else if (intrinsic->name == "reshape") {
       if (call.arguments().size() >= 2 && call.arguments().at(1)) {
         // SHAPE(RESHAPE(array,shape)) -> shape
         if (const auto *shapeExpr{
                 call.arguments().at(1).value().UnwrapExpr()}) {
           auto shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
-          return AsShape(context_, ConvertToType<ExtentType>(std::move(shape)));
+          return AsShape(ConvertToType<ExtentType>(std::move(shape)));
         }
       }
     } else if (intrinsic->name == "pack") {
       if (call.arguments().size() >= 3 && call.arguments().at(2)) {
         // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
         return (*this)(call.arguments().at(2));
-      } else if (call.arguments().size() >= 2) {
+      } else if (call.arguments().size() >= 2 && context_) {
         if (auto maskShape{(*this)(call.arguments().at(1))}) {
           if (maskShape->size() == 0) {
             // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
             if (auto arrayShape{(*this)(call.arguments().at(0))}) {
               auto arraySize{GetSize(std::move(*arrayShape))};
               CHECK(arraySize);
               ActualArguments toMerge{
                   ActualArgument{AsGenericExpr(std::move(*arraySize))},
                   ActualArgument{AsGenericExpr(ExtentExpr{0})},
                   common::Clone(call.arguments().at(1))};
-              auto specific{context_.intrinsics().Probe(
-                  CallCharacteristics{"merge"}, toMerge, context_)};
+              auto specific{context_->intrinsics().Probe(
+                  CallCharacteristics{"merge"}, toMerge, *context_)};
               CHECK(specific);
               return Shape{ExtentExpr{FunctionRef<ExtentType>{
                   ProcedureDesignator{std::move(specific->specificIntrinsic)},
                   std::move(specific->arguments)}}};
             }
           } else {
             // Non-scalar MASK= -> [COUNT(mask)]
             ActualArguments toCount{ActualArgument{common::Clone(
                 DEREF(call.arguments().at(1).value().UnwrapExpr()))}};
-            auto specific{context_.intrinsics().Probe(
-                CallCharacteristics{"count"}, toCount, context_)};
+            auto specific{context_->intrinsics().Probe(
+                CallCharacteristics{"count"}, toCount, *context_)};
             CHECK(specific);
             return Shape{ExtentExpr{FunctionRef<ExtentType>{
                 ProcedureDesignator{std::move(specific->specificIntrinsic)},
                 std::move(specific->arguments)}}};
           }
         }
       }
     } else if (intrinsic->name == "spread") {
if (call.Rank() == 0) {
     } else if (intrinsic->name == "transfer") {
       if (call.arguments().size() == 3 && call.arguments().at(2)) {
         // SIZE= is present; shape is vector [SIZE=]
         if (const auto *size{
                 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
           return Shape{
               MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
         }
-      } else if (auto moldTypeAndShape{
-                     characteristics::TypeAndShape::Characterize(
-                         call.arguments().at(1), context_)}) {
+      } else if (context_) {
+        if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
+                call.arguments().at(1), *context_)}) {
           if (GetRank(moldTypeAndShape->shape()) == 0) {
             // SIZE= is absent and MOLD= is scalar: result is scalar
-          return Scalar();
+            return ScalarShape();
           } else {
             // SIZE= is absent and MOLD= is array: result is vector whose
             // length is determined by sizes of types.  See 16.9.193p4 case(ii).
             if (auto sourceTypeAndShape{
                     characteristics::TypeAndShape::Characterize(
-                      call.arguments().at(0), context_)}) {
-            auto sourceBytes{sourceTypeAndShape->MeasureSizeInBytes(context_)};
+                        call.arguments().at(0), *context_)}) {
+              auto sourceBytes{
+                  sourceTypeAndShape->MeasureSizeInBytes(*context_)};
               auto moldElementBytes{
-                moldTypeAndShape->type().MeasureSizeInBytes(context_, true)};
+                  moldTypeAndShape->type().MeasureSizeInBytes(*context_, true)};
               if (sourceBytes && moldElementBytes) {
-              ExtentExpr extent{Fold(context_,
-                  (std::move(*sourceBytes) + common::Clone(*moldElementBytes) -
-                      ExtentExpr{1}) /
+                ExtentExpr extent{Fold(*context_,
+                    (std::move(*sourceBytes) +
+                        common::Clone(*moldElementBytes) - ExtentExpr{1}) /
                         common::Clone(*moldElementBytes))};
                 return Shape{MaybeExtentExpr{std::move(extent)}};
               }
             }
           }
         }
+      }
     } else if (intrinsic->name == "transpose") {
       if (call.arguments().size() >= 1) {
         if (auto shape{(*this)(call.arguments().at(0))}) {
           if (shape->size() == 2) {
             std::swap((*shape)[0], (*shape)[1]);
             return shape;
           }
         }

flang/lib/Evaluate/tools.cpp

std::optional<Expr<SomeType>> ConvertToType(
     const Symbol &to, std::optional<Expr<SomeType>> &&x) {
   if (x) {
     return ConvertToType(to, std::move(*x));
   } else {
     return std::nullopt;
   }
 }
 
-bool IsAssumedRank(const Symbol &symbol0) {
-  const Symbol &symbol{ResolveAssociations(symbol0)};
+bool IsAssumedRank(const Symbol &original) {
+  const Symbol &symbol{semantics::ResolveAssociations(original)};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     return details->IsAssumedRank();
   } else {
     return false;
   }
 }
 
 bool IsAssumedRank(const ActualArgument &arg) {
const Symbol *GetLastTarget(const SymbolVector &symbols) {
   // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
   auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
     return x.attrs().HasAny(
         {semantics::Attr::POINTER, semantics::Attr::TARGET});
   })};
   return iter == end ? nullptr : &**iter;
 }
 
-const Symbol &ResolveAssociations(const Symbol &symbol) {
-  if (const auto *details{symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
-      return ResolveAssociations(*nested);
-    }
-  }
-  return symbol.GetUltimate();
-}
-
 struct CollectSymbolsHelper
     : public SetTraverse<CollectSymbolsHelper, semantics::SymbolSet> {
   using Base = SetTraverse<CollectSymbolsHelper, semantics::SymbolSet>;
   CollectSymbolsHelper() : Base{*this} {}
   using Base::operator();
   semantics::SymbolSet operator()(const Symbol &symbol) const {
     return {symbol};
   }
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
   }
   return msg;
 }
 
 } // namespace Fortran::evaluate
 
 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;
+}
+
 // When a construct association maps to a variable, and that variable
 // is not an array with a vector-valued subscript, return the base
 // Symbol of that variable, else nullptr.  Descends into other construct
 // associations when one associations maps to another.
-static const Symbol *GetAssociatedVariable(
-    const semantics::AssocEntityDetails &details) {
+static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
   if (const auto &expr{details.expr()}) {
     if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
       if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
-        return GetAssociationRoot(*varSymbol);
+        return &GetAssociationRoot(*varSymbol);
       }
     }
   }
   return nullptr;
 }
 
-const Symbol *GetAssociationRoot(const Symbol &symbol) {
-  const Symbol &ultimate{symbol.GetUltimate()};
-  const auto *details{ultimate.detailsIf<semantics::AssocEntityDetails>()};
-  return details ? GetAssociatedVariable(*details) : &ultimate;
-}
-
-Symbol *GetAssociationRoot(Symbol &symbol) {
-  return const_cast<Symbol *>(
-      GetAssociationRoot(const_cast<const Symbol &>(symbol)));
+const Symbol &GetAssociationRoot(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
+  if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
+    if (const Symbol * root{GetAssociatedVariable(*details)}) {
+      return *root;
+    }
+  }
+  return symbol;
+}
+
+bool IsVariableName(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
+  if (symbol.has<ObjectEntityDetails>()) {
+    return !IsNamedConstant(symbol);
+  } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
+    const auto &expr{assoc->expr()};
+    return expr && IsVariable(*expr) && !HasVectorSubscript(*expr);
+  } else {
+    return false;
   }
-
-bool IsVariableName(const Symbol &symbol) {
-  const Symbol *root{GetAssociationRoot(symbol)};
-  return root && root->has<ObjectEntityDetails>() && !IsNamedConstant(*root);
 }
 
-bool IsPureProcedure(const Symbol &symbol) {
+bool IsPureProcedure(const Symbol &original) {
+  const Symbol &symbol{original.GetUltimate()};
   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
     if (const Symbol * procInterface{procDetails->interface().symbol()}) {
       // procedure component with a pure interface
       return IsPureProcedure(*procInterface);
     }
   } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
     return IsPureProcedure(details->symbol());
   } else if (!IsProcedure(symbol)) {
     return false;
   }
   if (IsStmtFunction(symbol)) {
     // Section 15.7(1) states that a statement function is PURE if it does not
     // reference an IMPURE procedure or a VOLATILE variable
     if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
       for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
         if (IsFunction(*ref) && !IsPureProcedure(*ref)) {
           return false;
         }
-        const Symbol *root{GetAssociationRoot(*ref)};
-        if (root && root->attrs().test(Attr::VOLATILE)) {
+        if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
           return false;
         }
       }
     }
     return true; // statement function was not found to be impure
   }
   return symbol.attrs().test(Attr::PURE) ||
       (symbol.attrs().test(Attr::ELEMENTAL) &&
return std::visit(
           [&](const SubprogramNameDetails &) {
             return symbol.test(Symbol::Flag::Function);
           },
           [](const ProcEntityDetails &x) {
             const auto &ifc{x.interface()};
             return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
           },
           [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
-          [](const UseDetails &x) { return IsFunction(x.symbol()); },
           [](const auto &) { return false; },
       },
-      symbol.details());
+      symbol.GetUltimate().details());
 }
 
 bool IsProcedure(const Symbol &symbol) {
-  return std::visit(
-      common::visitors{
+  return std::visit(common::visitors{
                         [](const SubprogramDetails &) { return true; },
                         [](const SubprogramNameDetails &) { return true; },
                         [](const ProcEntityDetails &) { return true; },
                         [](const GenericDetails &) { return true; },
                         [](const ProcBindingDetails &) { return true; },
-          [](const UseDetails &x) { return IsProcedure(x.symbol()); },
                         [](const auto &) { return false; },
                     },
-      symbol.details());
+      symbol.GetUltimate().details());
 }
 
 const Symbol *FindCommonBlockContaining(const Symbol &object) {
   const auto *details{object.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;
 }
 
-bool IsProcedurePointer(const Symbol &symbol) {
+bool IsProcedurePointer(const Symbol &original) {
+  const Symbol &symbol{original.GetUltimate()};
   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
 }
 
 bool IsSaved(const Symbol &original) {
-  if (const Symbol * root{GetAssociationRoot(original)}) {
-    const Symbol &symbol{*root};
-    const Scope *scope{&symbol.owner()};
-    auto scopeKind{scope->kind()};
-    if (scopeKind == Scope::Kind::Module) {
-      return true; // BLOCK DATA entities must all be in COMMON, handled below
-    } else if (symbol.attrs().test(Attr::SAVE)) {
-      return true;
-    } else if (scopeKind == Scope::Kind::DerivedType) {
-      return false; // this is a component
-    } else if (IsNamedConstant(symbol)) {
-      return false;
-    } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
-               object && object->init()) {
-      return true;
-    } else if (IsProcedurePointer(symbol) &&
-        symbol.get<ProcEntityDetails>().init()) {
-      return true;
-    } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
-               block && block->attrs().test(Attr::SAVE)) {
-      return true;
-    } else if (IsDummy(symbol) || IsFunctionResult(symbol)) {
-      return false;
-    } else if (scope->hasSAVE() ) {
-      return true;
-    }
+  const Symbol &symbol{GetAssociationRoot(original)};
+  const Scope &scope{symbol.owner()};
+  auto scopeKind{scope.kind()};
+  if (symbol.has<AssocEntityDetails>()) {
+    return false; // ASSOCIATE(non-variable)
+  } else if (scopeKind == Scope::Kind::Module) {
+  } else {
+    return scope.hasSAVE();
   }
-  return false;
 }
 
 bool IsDummy(const Symbol &symbol) {
   return std::visit(
       common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
           [](const ObjectEntityDetails &x) { return x.isDummy(); },
           [](const ProcEntityDetails &x) { return x.isDummy(); },
-          [](const HostAssocDetails &x) { return IsDummy(x.symbol()); },
           [](const auto &) { return false; }},
-      symbol.details());
+      ResolveAssociations(symbol).details());
 }
 
-bool IsFunctionResult(const Symbol &symbol) {
+bool IsFunctionResult(const Symbol &original) {
+  const Symbol &symbol{GetAssociationRoot(original)};
   return (symbol.has<ObjectEntityDetails>() &&
              symbol.get<ObjectEntityDetails>().isFuncResult()) ||
       (symbol.has<ProcEntityDetails>() &&
           symbol.get<ProcEntityDetails>().isFuncResult());
 }
 
 bool IsKindTypeParameter(const Symbol &symbol) {
-  const auto *param{symbol.detailsIf<TypeParamDetails>()};
+  const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
   return param && param->attr() == common::TypeParamAttr::Kind;
 }
 
 bool IsLenTypeParameter(const Symbol &symbol) {
-  const auto *param{symbol.detailsIf<TypeParamDetails>()};
+  const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
   return param && param->attr() == common::TypeParamAttr::Len;
 }
 
 int CountLenParameters(const DerivedTypeSpec &type) {
   return std::count_if(type.parameters().begin(), type.parameters().end(),
       [](const auto &pair) { return pair.second.isLen(); });
 }
 

flang/lib/Semantics/check-call.cpp

if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
             dummyName, bad.BuildResultDesignatorName());
       }
     }
   }
 
   // Rank and shape checks
   const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
   if (actualLastSymbol) {
-    actualLastSymbol = GetAssociationRoot(*actualLastSymbol);
+    actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
   }
   const ObjectEntityDetails *actualLastObject{actualLastSymbol
-          ? actualLastSymbol->GetUltimate().detailsIf<ObjectEntityDetails>()
+          ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
           : nullptr};
   int actualRank{evaluate::GetRank(actualType.shape())};
   bool actualIsPointer{(actualLastSymbol && IsPointer(*actualLastSymbol)) ||
       evaluate::IsNullPointer(actual)};
   if (dummy.type.attrs().test(
           characteristics::TypeAndShape::Attr::AssumedShape)) {
     // 15.5.2.4(16)
     if (actualRank == 0) {

flang/lib/Semantics/check-declarations.cpp

if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
           }
         }
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
   }
-  if (IsInitialized(symbol, true /* ignore DATA inits */)) { // C808
+  if (IsStaticallyInitialized(symbol, true /* ignore DATA inits */)) { // C808
     CheckPointerInitialization(symbol);
     if (IsAutomatic(symbol)) {
       messages_.Say(
           "An automatic variable or component must not be initialized"_err_en_US);
     } else if (IsDummy(symbol)) {
       messages_.Say("A dummy argument must not be initialized"_err_en_US);
     } else if (IsFunctionResult(symbol)) {
       messages_.Say("A function result must not be initialized"_err_en_US);

flang/lib/Semantics/check-do-forall.cpp

public:
   // entity, assignment to an allocatable variable, or an actual DEALLOCATE
   // statement
   //
   // Note also that the deallocation of a derived type entity might cause the
   // invocation of an IMPURE final subroutine. (C1139)
   //
 
   // Only to be called for symbols with ObjectEntityDetails
-  static bool HasImpureFinal(const Symbol &symbol) {
-    if (const Symbol * root{GetAssociationRoot(symbol)}) {
-      CHECK(root->has<ObjectEntityDetails>());
-      if (const DeclTypeSpec * symType{root->GetType()}) {
+  static bool HasImpureFinal(const Symbol &original) {
+    const Symbol &symbol{ResolveAssociations(original)};
+    if (symbol.has<ObjectEntityDetails>()) {
+      if (const DeclTypeSpec * symType{symbol.GetType()}) {
         if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
           return semantics::HasImpureFinal(*derived);
         }
       }
     }
     return false;
   }
 
   // Predicate for deallocations caused by block exit and direct deallocation
   static bool DeallocateAll(const Symbol &) { return true; }
 
   // Predicate for deallocations caused by intrinsic assignment
   static bool DeallocateNonCoarray(const Symbol &component) {
     return !IsCoarray(component);
   }
 
   static bool WillDeallocatePolymorphic(const Symbol &entity,
       const std::function<bool(const Symbol &)> &WillDeallocate) {
     return WillDeallocate(entity) && IsPolymorphicAllocatable(entity);
   }
 
   // Is it possible that we will we deallocate a polymorphic entity or one
   // of its components?
-  static bool MightDeallocatePolymorphic(const Symbol &entity,
+  static bool MightDeallocatePolymorphic(const Symbol &original,
       const std::function<bool(const Symbol &)> &WillDeallocate) {
-    if (const Symbol * root{GetAssociationRoot(entity)}) {
-      // Check the entity itself, no coarray exception here
-      if (IsPolymorphicAllocatable(*root)) {
-        return true;
-      }
-      // Check the components
-      if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
-        if (const DeclTypeSpec * entityType{details->type()}) {
-          if (const DerivedTypeSpec * derivedType{entityType->AsDerived()}) {
-            UltimateComponentIterator ultimates{*derivedType};
-            for (const auto &ultimate : ultimates) {
-              if (WillDeallocatePolymorphic(ultimate, WillDeallocate)) {
-                return true;
-              }
-            }
-          }
-        }
-      }
-    }
+    const Symbol &symbol{ResolveAssociations(original)};
+    if (IsPolymorphicAllocatable(symbol)) {
+    if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
     return false;
   }
 
   void SayDeallocateWithImpureFinal(const Symbol &entity, const char *reason) {
     context_.SayWithDecl(entity, currentStatementSourcePosition_,
         "Deallocation of an entity with an IMPURE FINAL procedure"
         " caused by %s not allowed in DO CONCURRENT"_err_en_US,
         reason);
const Scope &parentScope{
         context_.FindScope(currentStatementSourcePosition_).parent()};
     // Loop through the LocalitySpec::Local locality-specs
     for (const auto &ls : localitySpecs) {
       if (const auto *names{std::get_if<parser::LocalitySpec::Local>(&ls.u)}) {
         // Loop through the names in the Local locality-spec getting their
         // symbols
         for (const parser::Name &name : names->v) {
           if (const Symbol * symbol{parentScope.FindSymbol(name.source)}) {
-            if (const Symbol * root{GetAssociationRoot(*symbol)}) {
-              symbols.insert(*root);
-            }
+            symbols.insert(ResolveAssociations(*symbol));
           }
         }
       }
     }
     return symbols;
   }
 
   static SymbolSet GatherSymbolsFromExpression(const parser::Expr &expression) {
     SymbolSet result;
     if (const auto *expr{GetExpr(expression)}) {
       for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) {
-        if (const Symbol * root{GetAssociationRoot(symbol)}) {
-          result.insert(*root);
-        }
+        result.insert(ResolveAssociations(symbol));
       }
     }
     return result;
   }
 
   // C1121 - procedures in mask must be pure
   void CheckMaskIsPure(const parser::ScalarLogicalExpr &mask) const {
     SymbolSet references{GatherSymbolsFromExpression(mask.thing.thing.value())};

flang/lib/Semantics/resolve-names.cpp

if (prev) {
     }
     name.symbol = nullptr;
   }
   auto &symbol{DeclareObjectEntity(name)};
   if (symbol.GetType()) {
     // type came from explicit type-spec
   } else if (!prev) {
     ApplyImplicitRules(symbol);
-  } else if (const Symbol * prevRoot{GetAssociationRoot(*prev)}) {
+  } else {
+    const Symbol &prevRoot{ResolveAssociations(*prev)};
     // prev could be host- use- or construct-associated with another symbol
-    if (!prevRoot->has<ObjectEntityDetails>() &&
-        !prevRoot->has<EntityDetails>()) {
+    if (!prevRoot.has<ObjectEntityDetails>() &&
+        !prevRoot.has<EntityDetails>()) {
       Say2(name, "Index name '%s' conflicts with existing identifier"_err_en_US,
           *prev, "Previous declaration of '%s'"_en_US);
       return;
     } else {
-      if (const auto *type{prevRoot->GetType()}) {
+      if (const auto *type{prevRoot.GetType()}) {
         symbol.SetType(*type);
       }
-      if (prevRoot->IsObjectArray()) {
+      if (prevRoot.IsObjectArray()) {
         SayWithDecl(name, *prev, "Index variable '%s' is not scalar"_err_en_US);
         return;
       }
     }
   }
   EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}});
 }
 
bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
   auto &bounds{std::get<parser::DataImpliedDo::Bounds>(x.t)};
   DeclareStatementEntity(bounds.name.thing.thing, type);
   Walk(bounds);
   Walk(objects);
   return false;
 }
 
 // Sets InDataStmt flag on a variable (or misidentified function) in a DATA
-// statement so that the predicate IsInitialized(base symbol) will be true
+// statement so that the predicate IsStaticallyInitialized() will be true
 // during semantic analysis before the symbol's initializer is constructed.
 bool ConstructVisitor::Pre(const parser::DataIDoObject &x) {
   std::visit(
       common::visitors{
           [&](const parser::Scalar<Indirection<parser::Designator>> &y) {
             Walk(y.thing.value());
             const parser::Name &first{parser::GetFirstName(y.thing.value())};
             if (first.symbol) {

 }
 
 bool ConstructVisitor::Pre(const parser::DataStmtValue &x) {
   const auto &data{std::get<parser::DataStmtConstant>(x.t)};
   auto &mutableData{const_cast<parser::DataStmtConstant &>(data)};
   if (auto *elem{parser::Unwrap<parser::ArrayElement>(mutableData)}) {
     if (const auto *name{std::get_if<parser::Name>(&elem->base.u)}) {
       if (const Symbol * symbol{FindSymbol(*name)}) {
-        if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) {
-          if (ultimate->has<DerivedTypeDetails>()) {
-            mutableData.u = elem->ConvertToStructureConstructor(
-                DerivedTypeSpec{name->source, *ultimate});
-          }
+        const Symbol &ultimate{symbol->GetUltimate()};
+        if (ultimate.has<DerivedTypeDetails>()) {
+              DerivedTypeSpec{name->source, ultimate});
         }
       }
     }
   }
   return true;
 }
 
 bool ConstructVisitor::Pre(const parser::DoConstruct &x) {

flang/lib/Semantics/semantics.cpp

 
 void SemanticsContext::PopConstruct() {
   CHECK(!constructStack_.empty());
   constructStack_.pop_back();
 }
 
 void SemanticsContext::CheckIndexVarRedefine(const parser::CharBlock &location,
     const Symbol &variable, parser::MessageFixedText &&message) {
-  if (const Symbol * root{GetAssociationRoot(variable)}) {
-    auto it{activeIndexVars_.find(*root)};
-    if (it != activeIndexVars_.end()) {
-      std::string kind{EnumToString(it->second.kind)};
-      Say(location, std::move(message), kind, root->name())
-          .Attach(it->second.location, "Enclosing %s construct"_en_US, kind);
-    }
-  }
-}
+  const Symbol &symbol{ResolveAssociations(variable)};
+  auto it{activeIndexVars_.find(symbol)};
+    Say(location, std::move(message), kind, symbol.name())
 
 void SemanticsContext::WarnIndexVarRedefine(
     const parser::CharBlock &location, const Symbol &variable) {
   CheckIndexVarRedefine(
       location, variable, "Possible redefinition of %s variable '%s'"_en_US);
 }
 
 void SemanticsContext::CheckIndexVarRedefine(
if (const Symbol * entity{name.symbol}) {
     CheckIndexVarRedefine(name.source, *entity);
   }
 }
 
 void SemanticsContext::ActivateIndexVar(
     const parser::Name &name, IndexVarKind kind) {
   CheckIndexVarRedefine(name);
   if (const Symbol * indexVar{name.symbol}) {
-    if (const Symbol * root{GetAssociationRoot(*indexVar)}) {
-      activeIndexVars_.emplace(*root, IndexVarInfo{name.source, kind});
-    }
+    activeIndexVars_.emplace(
+        ResolveAssociations(*indexVar), IndexVarInfo{name.source, kind});
   }
 }
 
 void SemanticsContext::DeactivateIndexVar(const parser::Name &name) {
   if (Symbol * indexVar{name.symbol}) {
-    if (const Symbol * root{GetAssociationRoot(*indexVar)}) {
-      auto it{activeIndexVars_.find(*root)};
-      if (it != activeIndexVars_.end() && it->second.location == name.source) {
-        activeIndexVars_.erase(it);
-      }
-    }
-  }
-}
+    auto it{activeIndexVars_.find(ResolveAssociations(*indexVar))};
 
 SymbolVector SemanticsContext::GetIndexVars(IndexVarKind kind) {
   SymbolVector result;
   for (const auto &[symbol, info] : activeIndexVars_) {
     if (info.kind == kind) {
       result.push_back(symbol);
     }
   }

flang/lib/Semantics/tools.cpp

bool IsTeamType(const DerivedTypeSpec *derived) {
   return IsBuiltinDerivedType(derived, "team_type");
 }
 
 bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
   return IsBuiltinDerivedType(derivedTypeSpec, "event_type") ||
       IsBuiltinDerivedType(derivedTypeSpec, "lock_type");
 }
 
-bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {
-  if (const Symbol * root{GetAssociationRoot(symbol)}) {
-    if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
-      if (const DeclTypeSpec * type{details->type()}) {
-        if (const DerivedTypeSpec * derived{type->AsDerived()}) {
-          return IsEventTypeOrLockType(derived) ||
-              FindEventOrLockPotentialComponent(*derived);
-        }
-      }
-    }
-  }
+bool IsOrContainsEventOrLockComponent(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
+  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
   return false;
 }
 
 // Check this symbol suitable as a type-bound procedure - C769
 bool CanBeTypeBoundProc(const Symbol *symbol) {
   if (!symbol || IsDummy(*symbol) || IsProcedurePointer(*symbol)) {
     return false;
   } else if (symbol->has<SubprogramNameDetails>()) {
     return symbol->owner().kind() == Scope::Kind::Module;
   } else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
     return symbol->owner().kind() == Scope::Kind::Module ||
         details->isInterface();
   } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
     return !symbol->attrs().test(Attr::INTRINSIC) &&
         proc->HasExplicitInterface();
   } else {
     return false;
   }
 }
 
-bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements,
-    const Symbol *derivedTypeSymbol) {
+bool IsStaticallyInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
   if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
     return true;
   } else if (IsNamedConstant(symbol)) {
     return false;
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (object->init()) {
-      return true;
-    } else if (object->isDummy() || IsFunctionResult(symbol)) {
-      return false;
-    } else if (IsAllocatable(symbol)) {
-      return true;
-    } else if (!IsPointer(symbol) && object->type()) {
-      if (const auto *derived{object->type()->AsDerived()}) {
-        if (&derived->typeSymbol() == derivedTypeSymbol) {
-          // error recovery: avoid infinite recursion on invalid
-          // recursive usage of a derived type
-        } else if (derived->HasDefaultInitialization()) {
-          return true;
-        }
-      }
-    }
-  } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
-    return proc->init().has_value();
-  }
+    return object->init().has_value();
+  } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+    return proc->init().has_value();
+  }
+}
+
+bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements,
+    const Symbol *derivedTypeSymbol) {
+  if (IsStaticallyInitialized(symbol, ignoreDATAstatements) ||
+      IsAllocatable(symbol)) {
+  } else if (IsNamedConstant(symbol) || IsFunctionResult(symbol) ||
+      IsPointer(symbol)) {
+    return false;
+  } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    if (!object->isDummy() && object->type()) {
+      const auto *derived{object->type()->AsDerived()};
+      return derived && &derived->typeSymbol() != derivedTypeSymbol &&
+          derived->HasDefaultInitialization();
   return false;
 }
 
 bool HasIntrinsicTypeName(const Symbol &symbol) {
   std::string name{symbol.name().ToString()};
   if (name == "doubleprecision") {
     return true;
   } else if (name == "derived") {

 }
 
 bool IsModuleProcedure(const Symbol &symbol) {
   return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module;
 }
 const Symbol *IsExternalInPureContext(
     const Symbol &symbol, const Scope &scope) {
   if (const auto *pureProc{FindPureProcedureContaining(scope)}) {
-    if (const Symbol * root{GetAssociationRoot(symbol)}) {
-      if (const Symbol *
-          visible{FindExternallyVisibleObject(*root, *pureProc)}) {
-        return visible;
-      }
-    }
+    return FindExternallyVisibleObject(symbol.GetUltimate(), *pureProc);
   }
   return nullptr;
 }
 
 PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent(
     const DerivedTypeSpec &derived) {
   PotentialComponentIterator potentials{derived};
   return std::find_if(
       potentials.begin(), potentials.end(), [](const Symbol &component) {
         if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
           const DeclTypeSpec *type{details->type()};
           return type && type->IsPolymorphic();
         }
         return false;
       });
 }
 
-bool IsOrContainsPolymorphicComponent(const Symbol &symbol) {
-  if (const Symbol * root{GetAssociationRoot(symbol)}) {
-    if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
-      if (const DeclTypeSpec * type{details->type()}) {
-        if (type->IsPolymorphic()) {
-          return true;
-        }
-        if (const DerivedTypeSpec * derived{type->AsDerived()}) {
-          return (bool)FindPolymorphicPotentialComponent(*derived);
-        }
-      }
-    }
-  }
+bool IsOrContainsPolymorphicComponent(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
+  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
   return false;
 }
 
 bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
   return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope);
 }
 
 // C1101 and C1158
 std::optional<parser::MessageFixedText> WhyNotModifiable(
-    const Symbol &symbol, const Scope &scope) {
-  const Symbol *root{GetAssociationRoot(symbol)};
-  if (!root) {
+    const Symbol &original, const Scope &scope) {
+  const Symbol &symbol{GetAssociationRoot(original)};
+  if (symbol.has<AssocEntityDetails>()) {
     return "'%s' is construct associated with an expression"_en_US;
-  } else if (InProtectedContext(*root, scope)) {
+  } else if (InProtectedContext(symbol, scope)) {
     return "'%s' is protected in this scope"_en_US;
-  } else if (IsExternalInPureContext(*root, scope)) {
+  } else if (IsExternalInPureContext(symbol, scope)) {
     return "'%s' is externally visible and referenced in a pure"
            " procedure"_en_US;
-  } else if (IsOrContainsEventOrLockComponent(*root)) {
+  } else if (IsOrContainsEventOrLockComponent(symbol)) {
     return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US;
-  } else if (IsIntentIn(*root)) {
+  } else if (IsIntentIn(symbol)) {
     return "'%s' is an INTENT(IN) dummy argument"_en_US;
-  } else if (!IsVariableName(*root)) {
+  } else if (!IsVariableName(symbol)) {
     return "'%s' is not a variable"_en_US;
   } else {
     return std::nullopt;
   }
 }
 
 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
     const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
return std::visit(
           [](const auto &) { return parser::CharBlock{}; },
       },
       executableConstruct.u);
 }
 
 bool HasCoarray(const parser::Expr &expression) {
   if (const auto *expr{GetExpr(expression)}) {
     for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) {
-      if (const Symbol * root{GetAssociationRoot(symbol)}) {
-        if (IsCoarray(*root)) {
-          return true;
-        }
-      }
-    }
-  }
+      if (IsCoarray(GetAssociationRoot(symbol))) {
   return false;
 }
 
 bool IsPolymorphic(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->IsPolymorphic();
   }
   return false;

flang/test/Semantics/data04.f90

subroutine CheckObject(i)
       type large
         integer, allocatable :: allocVal
         integer, allocatable :: elt(:)
         integer val
         type(specialNumbers) numsArray(5)
       end type
       type(large) largeNumber
       type(large), allocatable :: allocatableLarge
-      !ERROR: An automatic variable or component must not be initialized
       type(large) :: largeNumberArray(i)
       type(large) :: largeArray(5)
       character :: name(i)
       !C877
       !ERROR: Default-initialized 'largenumber' must not be initialized in a DATA statement
       DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() /
       !C877
       !ERROR: Data object must not contain pointer 'headofthelist' as a non-rightmost part

flang/test/Semantics/resolve44.f90

type :: recursive1
     class(recursive1) :: bad2
     class(recursive1), pointer :: ok3
     class(recursive1), allocatable :: ok4
   end type recursive1
   type :: recursive2(kind,len)
     integer, kind :: kind
     integer, len :: len
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
-    !ERROR: An automatic variable or component must not be initialized
     type(recursive2(kind,len)) :: bad1
     type(recursive2(kind,len)), pointer :: ok1
     type(recursive2(kind,len)), allocatable :: ok2
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
-    !ERROR: An automatic variable or component must not be initialized
     !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
     class(recursive2(kind,len)) :: bad2
     class(recursive2(kind,len)), pointer :: ok3
     class(recursive2(kind,len)), allocatable :: ok4
   end type recursive2
   type :: recursive3(kind,len)
     integer, kind :: kind = 1
     integer, len :: len = 2

flang/test/Semantics/shape.f90

 ! RUN: %S/test_errors.sh %s %t %f18
 ! Test comparisons that use the intrinsic SHAPE() as an operand
 program testShape
 contains
   subroutine sub1(arrayDummy)
     integer :: arrayDummy(:)
     integer, allocatable :: arrayDeferred(:)
     integer :: arrayLocal(2) = [88, 99]
+    !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0
+    !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0
     if (all(shape(arrayDummy)==shape(8))) then
       print *, "hello"
     end if
+    !ERROR: Dimension 1 of left operand has extent 0, but right operand has extent 1
+    !ERROR: Dimension 1 of left operand has extent 0, but right operand has extent 1
     if (all(shape(27)==shape(arrayDummy))) then
       print *, "hello"
     end if
     if (all(64==shape(arrayDummy))) then
       print *, "hello"
     end if
+    !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0
+    !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0
     if (all(shape(arrayDeferred)==shape(8))) then
       print *, "hello"
     end if
+    !ERROR: Dimension 1 of left operand has extent 0, but right operand has extent 1
+    !ERROR: Dimension 1 of left operand has extent 0, but right operand has extent 1
     if (all(shape(27)==shape(arrayDeferred))) then
       print *, "hello"
     end if
     if (all(64==shape(arrayDeferred))) then
       print *, "hello"
     end if
     !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0
     !ERROR: Dimension 1 of left operand has extent 1, but right operand has extent 0