[flang] Improve initializer semantics, esp. for component default values

[klausler]

Summary

This patch plugs many holes in static initializer semantics, improves error
messages for default initial values and other component properties in
parameterized derived type instantiations, and cleans up several small
issues noticed during development. We now do proper scalar expansion,
folding, and type, rank, and shape conformance checking for component
default initializers in derived types and PDT instantiations.
The initial values of named constants are now guaranteed to have been folded
when installed in the symbol table, and are no longer folded or
scalar-expanded at each use in expression folding. Semantics documentation
was extended with information about the various kinds of initializations
in Fortran and when each of them are processed in the compiler.

Some necessary concomitant changes have bulked this patch out a bit:

• contextual messages attachments, which are now produced for parameterized derived type instantiations so that the user can figure out which instance caused a problem with a component, have been added as part of ContextualMessages, and their implementation was debugged
• several APIs in evaluate::characteristics was changed so that a FoldingContext is passed as an argument rather than just its intrinsic procedure table; this affected client call sites in many files
• new tools in Evaluate/check-expression.cpp to determine when an Expr actually is a single constant value and to validate a non-pointer variable initializer or object component default value
• shape conformance checking has additional arguments that control whether scalar expansion is allowed
• several now-unused functions and data members noticed and removed
• several crashes and bogus errors exposed by testing this new code were fixed
• a -fdebug-stack-trace option to enable LLVM's stack tracing on a crash, which might be useful in the future

TL;DR: Initialization processing does more and takes place at the right
times for all of the various kinds of things that can be initialized.

[tskeith]

LGTM

flang/docs/Semantics.md

 have been. But there may be names without symbols or expressions without
 analyzed form if errors occurred earlier.
 
+### Initialization processing
+
+Fortran supports many means of specifying static initializers for variables,
+object pointers, and procedure pointers, as well as default initializers for
+derived type object components, pointers, and type parameters.
+
+Non-pointer static initializers of variables and named constants are
+scanned, analyzed, folded, scalar-expanded, and validated as they are
+traversed during declaration processing in name resolution.
+So are the default initializers of non-pointer object components in
+non-parameterized derived types.
+Name constant arrays with implied shapes take their actual shape from
+the initialization expression.
+
+Default initializers of non-pointer components and type parameters
+in distinct parameterized
+derived type instantiations are similarly processed as those instances
+are created, as their expressions may depend on the values of type
+parameters.
+Error messages produced during parameterized derived type instantiation
+are decorated with contextual attachments that point to the declarations
+or other type specifications that caused the instantiation.
+
+Static initializations in `DATA` statements are collected, validated,
+and converted into static initialization in the symbol table, as if
+the initialized objects had used the newer style of static initialization
+in their entity declarations.
+
+All statically initialized pointers, and default component initializers for
+pointers, are processed late in name resolution after all specification parts
+have been traversed.
+This allows for forward references even in the presence of `IMPLICIT NONE`.
+Object pointer initializers in parameterized derived type instantiations are
+also cloned and folded at this late stage.
+Validation of pointer initializers takes place later in declaration
+checking (below).
+
+### Declaration checking
+
+Whenever possible, the enforcement of constraints and "shalls" pertaining to
+properties of symbols is deferred to a single read-only pass over the symbol table
+that takes place after all name resolution and typing is complete.
+
 ### Write module files
 
 Separate compilation information is written out on successful compilation

flang/include/flang/Common/reference-counted.h

 template <typename A> class ReferenceCounted {
 public:
   ReferenceCounted() {}
+  int references() const { return references_; }
   void TakeReference() { ++references_; }
   void DropReference() {
     if (--references_ == 0) {

flang/include/flang/Evaluate/characteristics.h

 class raw_ostream;
 }
 
-namespace Fortran::evaluate {
-class IntrinsicProcTable;
-}
 namespace Fortran::evaluate::characteristics {
 struct Procedure;
 }

   static std::optional<TypeAndShape> Characterize(
       const semantics::Symbol &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::ObjectEntityDetails &);
+      const semantics::ObjectEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcInterface &);
   static std::optional<TypeAndShape> Characterize(

       const semantics::AssocEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &);
-  void AcquireShape(const semantics::ObjectEntityDetails &);
+  void AcquireShape(const semantics::ObjectEntityDetails &, FoldingContext &);
   void AcquireLEN();
 
 protected:

   bool operator!=(const DummyDataObject &that) const {
     return !(*this == that);
   }
-  static std::optional<DummyDataObject> Characterize(const semantics::Symbol &);
+  static std::optional<DummyDataObject> Characterize(
+      const semantics::Symbol &, FoldingContext &);
   bool CanBePassedViaImplicitInterface() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
   TypeAndShape type;

   bool operator==(const DummyProcedure &) const;
   bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
   static std::optional<DummyProcedure> Characterize(
-      const semantics::Symbol &, const IntrinsicProcTable &);
+      const semantics::Symbol &, FoldingContext &context);
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
   CopyableIndirection<Procedure> procedure;
   common::Intent intent{common::Intent::Default};

   bool operator==(const DummyArgument &) const;
   bool operator!=(const DummyArgument &that) const { return !(*this == that); }
   static std::optional<DummyArgument> Characterize(
-      const semantics::Symbol &, const IntrinsicProcTable &);
+      const semantics::Symbol &, FoldingContext &);
   static std::optional<DummyArgument> FromActual(
       std::string &&, const Expr<SomeType> &, FoldingContext &);
   bool IsOptional() const;

   bool operator==(const FunctionResult &) const;
   bool operator!=(const FunctionResult &that) const { return !(*this == that); }
   static std::optional<FunctionResult> Characterize(
-      const Symbol &, const IntrinsicProcTable &);
+      const Symbol &, FoldingContext &);
 
   bool IsAssumedLengthCharacter() const;
 

   // Characterizes the procedure represented by a symbol, which may be an
   // "unrestricted specific intrinsic function".
   static std::optional<Procedure> Characterize(
-      const semantics::Symbol &, const IntrinsicProcTable &);
+      const semantics::Symbol &, FoldingContext &);
   static std::optional<Procedure> Characterize(
-      const ProcedureDesignator &, const IntrinsicProcTable &);
+      const ProcedureDesignator &, FoldingContext &);
   static std::optional<Procedure> Characterize(
-      const ProcedureRef &, const IntrinsicProcTable &);
+      const ProcedureRef &, FoldingContext &);
 
   // At most one of these will return true.
   // For "EXTERNAL P" with no type for or calls to P, both will be false.

flang/include/flang/Evaluate/check-expression.h

 }
 
 namespace Fortran::evaluate {
-class IntrinsicProcTable;
 
 // Predicate: true when an expression is a constant expression (in the
 // strict sense of the Fortran standard); it may not (yet) be a hard

 extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
 extern template bool IsConstantExpr(const StructureConstructor &);
 
+// Predicate: true when an expression actually is a typed Constant<T>,
+// perhaps with parentheses and wrapping around it.  False for all typeless
+// expressions, including BOZ literals.
+template <typename A> bool IsActuallyConstant(const A &);
+extern template bool IsActuallyConstant(const Expr<SomeType> &);
+
 // Checks whether an expression is an object designator with
 // constant addressing and no vector-valued subscript.
 // If a non-null ContextualMessages pointer is passed, an error message

 bool IsInitialProcedureTarget(const ProcedureDesignator &);
 bool IsInitialProcedureTarget(const Expr<SomeType> &);
 
+// Validate the value of a named constant, the static initial
+// value of a non-pointer non-allocatable non-dummy variable, or the
+// default initializer of a component of a derived type (or instantiation
+// of a derived type).  Converts type and expands scalars as necessary.
+std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &,
+    Expr<SomeType> &&, FoldingContext &,
+    const semantics::Scope *instantiation = nullptr);
+
 // Check whether an expression is a specification expression
 // (10.1.11(2), C1010).  Constant expressions are always valid
 // specification expressions.
 
 template <typename A>
-void CheckSpecificationExpr(const A &, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &);
-extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
-extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+void CheckSpecificationExpr(
+    const A &, const semantics::Scope &, FoldingContext &);
+extern template void CheckSpecificationExpr(
+    const Expr<SomeType> &x, const semantics::Scope &, FoldingContext &);
+extern template void CheckSpecificationExpr(
+    const Expr<SomeInteger> &x, const semantics::Scope &, FoldingContext &);
 extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+    const semantics::Scope &, FoldingContext &);
 extern template void CheckSpecificationExpr(
-    const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &);
+    const std::optional<Expr<SomeType>> &x, const semantics::Scope &,
+    FoldingContext &);
 extern template void CheckSpecificationExpr(
-    const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &);
+    const std::optional<Expr<SomeInteger>> &x, const semantics::Scope &,
+    FoldingContext &);
 extern template void CheckSpecificationExpr(
-    const std::optional<Expr<SubscriptInteger>> &x,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+    const std::optional<Expr<SubscriptInteger>> &x, const semantics::Scope &,
+    FoldingContext &);
 
 // Simple contiguity (9.5.4)
-template <typename A>
-bool IsSimplyContiguous(const A &, const IntrinsicProcTable &);
+template <typename A> bool IsSimplyContiguous(const A &, FoldingContext &);
 extern template bool IsSimplyContiguous(
-    const Expr<SomeType> &, const IntrinsicProcTable &);
+    const Expr<SomeType> &, FoldingContext &);
+
+template <typename A> bool IsErrorExpr(const A &);
+extern template bool IsErrorExpr(const Expr<SomeType> &);
 
 } // namespace Fortran::evaluate
 #endif

flang/include/flang/Evaluate/common.h

   bool flushSubnormalsToZero() const { return flushSubnormalsToZero_; }
   bool bigEndian() const { return bigEndian_; }
   const semantics::DerivedTypeSpec *pdtInstance() const { return pdtInstance_; }
-  const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; }
+  const IntrinsicProcTable &intrinsics() const { return intrinsics_; }
 
   ConstantSubscript &StartImpliedDo(parser::CharBlock, ConstantSubscript = 1);
   std::optional<ConstantSubscript> GetImpliedDo(parser::CharBlock) const;

flang/include/flang/Evaluate/shape.h

 // are known.
 bool CheckConformance(parser::ContextualMessages &, const Shape &left,
     const Shape &right, const char *leftIs = "left operand",
-    const char *rightIs = "right operand");
+    const char *rightIs = "right operand", bool leftScalarExpandable = true,
+    bool rightScalarExpandable = true);
 
 // Increments one-based subscripts in element order (first varies fastest)
 // and returns true when they remain in range; resets them all to one and

flang/include/flang/Evaluate/tools.h

     while (const Component * component{std::get_if<Component>(&ref->u)}) {
       ref = &component->base();
     }
-    return std::holds_alternative<ArrayRef>(ref->u);
+    if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
+      return !coarrayRef->subscript().empty();
+    } else {
+      return std::holds_alternative<ArrayRef>(ref->u);
+    }
   } else {
     return false;
   }

 // Check for references to impure procedures; returns the name
 // of one to complain about, if any exist.
 std::optional<std::string> FindImpureCall(
-    const IntrinsicProcTable &, const Expr<SomeType> &);
+    FoldingContext &, const Expr<SomeType> &);
 std::optional<std::string> FindImpureCall(
-    const IntrinsicProcTable &, const ProcedureRef &);
+    FoldingContext &, const ProcedureRef &);
 
 // Predicate: is a scalar expression suitable for naive scalar expansion
 // in the flattening of an array expression?

     const std::optional<characteristics::Procedure> &lhsProcedure,
     const characteristics::Procedure *rhsProcedure);
 
+// Scalar constant expansion
+class ScalarConstantExpander {
+public:
+  explicit ScalarConstantExpander(ConstantSubscripts &&extents)
+      : extents_{std::move(extents)} {}
+  ScalarConstantExpander(
+      ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)
+      : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
+  ScalarConstantExpander(
+      ConstantSubscripts &&extents, ConstantSubscripts &&lbounds)
+      : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
+
+  template <typename A> A Expand(A &&x) const {
+    return std::move(x); // default case
+  }
+  template <typename T> Constant<T> Expand(Constant<T> &&x) {
+    auto expanded{x.Reshape(std::move(extents_))};
+    if (lbounds_) {
+      expanded.set_lbounds(std::move(*lbounds_));
+    }
+    return expanded;
+  }
+  template <typename T> Constant<T> Expand(Parentheses<T> &&x) {
+    return Expand(std::move(x)); // Constant<> can be parenthesized
+  }
+  template <typename T> Expr<T> Expand(Expr<T> &&x) {
+    return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
+        std::move(x.u));
+  }
+
+private:
+  ConstantSubscripts extents_;
+  std::optional<ConstantSubscripts> lbounds_;
+};
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {

 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 &);

flang/include/flang/Evaluate/type.h

 int SelectedRealKind(
     std::int64_t precision = 0, std::int64_t range = 0, std::int64_t radix = 2);
 
-// Utilities
-bool IsKindTypeParameter(const semantics::Symbol &);
-
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
   M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)

flang/include/flang/Parser/message.h

 
   CharBlock at() const { return at_; }
   Messages *messages() const { return messages_; }
+  Message::Reference contextMessage() const { return contextMessage_; }
   bool empty() const { return !messages_ || messages_->empty(); }
 
   // Set CharBlock for messages; restore when the returned value is deleted

     return common::ScopedSet(at_, std::move(at));
   }
 
+  common::Restorer<Message::Reference> SetContext(Message *m) {
+    if (!m) {
+      m = contextMessage_.get();
+    }
+    return common::ScopedSet(contextMessage_, m);
+  }
+
   // Diverts messages to another buffer; restored when the returned
   // value is deleted.
   common::Restorer<Messages *> SetMessages(Messages &buffer) {

 
   template <typename... A> Message *Say(CharBlock at, A &&...args) {
     if (messages_ != nullptr) {
-      return &messages_->Say(at, std::forward<A>(args)...);
+      auto &msg{messages_->Say(at, std::forward<A>(args)...)};
+      if (contextMessage_) {
+        msg.SetContext(contextMessage_.get());
+      }
+      return &msg;
     } else {
       return nullptr;
     }

 private:
   CharBlock at_;
   Messages *messages_{nullptr};
+  Message::Reference contextMessage_;
 };
 } // namespace Fortran::parser
 #endif // FORTRAN_PARSER_MESSAGE_H_

flang/include/flang/Semantics/scope.h

   bool IsDerivedType() const { return kind_ == Kind::DerivedType; }
   bool IsStmtFunction() const;
   bool IsParameterizedDerivedType() const;
+  bool IsParameterizedDerivedTypeInstantiation() const {
+    return kind_ == Kind::DerivedType && !symbol_;
+  }
   Symbol *symbol() { return symbol_; }
   const Symbol *symbol() const { return symbol_; }
 

 
   void add_importName(const SourceName &);
 
+  // These members pertain to instantiations of parameterized derived types.
   const DerivedTypeSpec *derivedTypeSpec() const { return derivedTypeSpec_; }
   DerivedTypeSpec *derivedTypeSpec() { return derivedTypeSpec_; }
   void set_derivedTypeSpec(DerivedTypeSpec &spec) { derivedTypeSpec_ = &spec; }
+  parser::Message::Reference instantiationContext() const {
+    return instantiationContext_;
+  };
+  void set_instantiationContext(parser::Message::Reference &&mref) {
+    instantiationContext_ = std::move(mref);
+  }
 
   bool hasSAVE() const { return hasSAVE_; }
   void set_hasSAVE(bool yes = true) { hasSAVE_ = yes; }

   std::optional<ImportKind> importKind_;
   std::set<SourceName> importNames_;
   DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
+  parser::Message::Reference instantiationContext_;
   bool hasSAVE_{false}; // scope has a bare SAVE statement
   // When additional data members are added to Scope, remember to
   // copy them, if appropriate, in InstantiateDerivedType().

flang/include/flang/Semantics/symbol.h

   MaybeExpr &init() { return init_; }
   const MaybeExpr &init() const { return init_; }
   void set_init(MaybeExpr &&expr) { init_ = std::move(expr); }
-  bool initWasValidated() const { return initWasValidated_; }
-  void set_initWasValidated(bool yes = true) { initWasValidated_ = yes; }
   ArraySpec &shape() { return shape_; }
   const ArraySpec &shape() const { return shape_; }
   ArraySpec &coshape() { return coshape_; }

 
 private:
   MaybeExpr init_;
-  bool initWasValidated_{false};
   ArraySpec shape_;
   ArraySpec coshape_;
   const Symbol *commonBlock_{nullptr}; // common block this object is in

flang/include/flang/Semantics/tools.h

 bool IsEventTypeOrLockType(const DerivedTypeSpec *);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
-bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false);
+bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false,
+    const Symbol *derivedType = nullptr);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
 bool IsAutomatic(const Symbol &);

flang/lib/Evaluate/characteristics.cpp

   return std::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
-            auto result{Characterize(object)};
+            auto result{Characterize(object, context)};
             if (result &&
                 result->type().category() == TypeCategory::Character) {
               if (auto len{DataRef{symbol}.LEN()}) {

               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);
           },

 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::ObjectEntityDetails &object) {
+    const semantics::ObjectEntityDetails &object, FoldingContext &context) {
   if (auto type{DynamicType::From(object.type())}) {
     TypeAndShape result{std::move(*type)};
-    result.AcquireShape(object);
+    result.AcquireShape(object, context);
     return result;
   } else {
     return std::nullopt;

     return false;
   }
   return isElemental ||
-      CheckConformance(messages, shape_, that.shape_, thisIs, thatIs);
+      CheckConformance(messages, shape_, that.shape_, thisIs, thatIs, false,
+          false /* no scalar expansion */);
 }
 
 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(

   }
 }
 
-void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
+void TypeAndShape::AcquireShape(
+    const semantics::ObjectEntityDetails &object, FoldingContext &context) {
   CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
   corank_ = object.coshape().Rank();
   if (object.IsAssumedRank()) {

         extent =
             std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
       }
-      shape_.emplace_back(std::move(extent));
+      shape_.emplace_back(Fold(context, std::move(extent)));
     } else {
       shape_.push_back(std::nullopt);
     }

 }
 
 std::optional<DummyDataObject> DummyDataObject::Characterize(
-    const semantics::Symbol &symbol) {
+    const semantics::Symbol &symbol, FoldingContext &context) {
   if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(*obj)}) {
+    if (auto type{TypeAndShape::Characterize(*obj, context)}) {
       std::optional<DummyDataObject> result{std::move(*type)};
       using semantics::Attr;
       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,

 }
 
 std::optional<DummyProcedure> DummyProcedure::Characterize(
-    const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
-  if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) {
+    const semantics::Symbol &symbol, FoldingContext &context) {
+  if (auto procedure{Procedure::Characterize(symbol, context)}) {
     // Dummy procedures may not be elemental.  Elemental dummy procedure
     // interfaces are errors when the interface is not intrinsic, and that
     // error is caught elsewhere.  Elemental intrinsic interfaces are

 }
 
 std::optional<DummyArgument> DummyArgument::Characterize(
-    const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+    const semantics::Symbol &symbol, FoldingContext &context) {
   auto name{symbol.name().ToString()};
   if (symbol.has<semantics::ObjectEntityDetails>()) {
-    if (auto obj{DummyDataObject::Characterize(symbol)}) {
+    if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
       return DummyArgument{std::move(name), std::move(obj.value())};
     }
-  } else if (auto proc{DummyProcedure::Characterize(symbol, intrinsics)}) {
+  } else if (auto proc{DummyProcedure::Characterize(symbol, context)}) {
     return DummyArgument{std::move(name), std::move(proc.value())};
   }
   return std::nullopt;

                     TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
           },
           [&](const ProcedureDesignator &designator) {
-            if (auto proc{Procedure::Characterize(
-                    designator, context.intrinsics())}) {
+            if (auto proc{Procedure::Characterize(designator, context)}) {
               return std::make_optional<DummyArgument>(
                   std::move(name), DummyProcedure{std::move(*proc)});
             } else {

             }
           },
           [&](const ProcedureRef &call) {
-            if (auto proc{
-                    Procedure::Characterize(call, context.intrinsics())}) {
+            if (auto proc{Procedure::Characterize(call, context)}) {
               return std::make_optional<DummyArgument>(
                   std::move(name), DummyProcedure{std::move(*proc)});
             } else {

 }
 
 std::optional<FunctionResult> FunctionResult::Characterize(
-    const Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+    const Symbol &symbol, FoldingContext &context) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(*object)}) {
+    if (auto type{TypeAndShape::Characterize(*object, context)}) {
       FunctionResult result{std::move(*type)};
       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
           {

           });
       return result;
     }
-  } else if (auto maybeProc{Procedure::Characterize(symbol, intrinsics)}) {
+  } else if (auto maybeProc{Procedure::Characterize(symbol, context)}) {
     FunctionResult result{std::move(*maybeProc)};
     result.attrs.set(FunctionResult::Attr::Pointer);
     return result;

 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
+    const semantics::Symbol &original, FoldingContext &context) {
   Procedure result;
   const auto &symbol{ResolveAssociations(original)};
   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,

           [&](const semantics::SubprogramDetails &subp)
               -> std::optional<Procedure> {
             if (subp.isFunction()) {
-              if (auto fr{FunctionResult::Characterize(
-                      subp.result(), intrinsics)}) {
+              if (auto fr{
+                      FunctionResult::Characterize(subp.result(), context)}) {
                 result.functionResult = std::move(fr);
               } else {
                 return std::nullopt;

               if (!arg) {
                 result.dummyArguments.emplace_back(AlternateReturn{});
               } else if (auto argCharacteristics{
-                             DummyArgument::Characterize(*arg, intrinsics)}) {
+                             DummyArgument::Characterize(*arg, context)}) {
                 result.dummyArguments.emplace_back(
                     std::move(argCharacteristics.value()));
               } else {

           [&](const semantics::ProcEntityDetails &proc)
               -> std::optional<Procedure> {
             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
-              return intrinsics.IsSpecificIntrinsicFunction(
+              return context.intrinsics().IsSpecificIntrinsicFunction(
                   symbol.name().ToString());
             }
             const semantics::ProcInterface &interface{proc.interface()};
             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
-              return Characterize(*interfaceSymbol, intrinsics);
+              return Characterize(*interfaceSymbol, context);
             } else {
               result.attrs.set(Attr::ImplicitInterface);
               const semantics::DeclTypeSpec *type{interface.type()};

             }
           },
           [&](const semantics::ProcBindingDetails &binding) {
-            if (auto result{Characterize(binding.symbol(), intrinsics)}) {
+            if (auto result{Characterize(binding.symbol(), context)}) {
               if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
                 auto passName{binding.passName()};
                 for (auto &dummy : result->dummyArguments) {

             }
           },
           [&](const semantics::UseDetails &use) {
-            return Characterize(use.symbol(), intrinsics);
+            return Characterize(use.symbol(), context);
           },
           [&](const semantics::HostAssocDetails &assoc) {
-            return Characterize(assoc.symbol(), intrinsics);
+            return Characterize(assoc.symbol(), context);
           },
           [](const auto &) { return std::optional<Procedure>{}; },
       },

 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
+    const ProcedureDesignator &proc, FoldingContext &context) {
   if (const auto *symbol{proc.GetSymbol()}) {
     if (auto result{characteristics::Procedure::Characterize(
-            ResolveAssociations(*symbol), intrinsics)}) {
+            ResolveAssociations(*symbol), context)}) {
       return result;
     }
   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {

 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
-  if (auto callee{Characterize(ref.proc(), intrinsics)}) {
+    const ProcedureRef &ref, FoldingContext &context) {
+  if (auto callee{Characterize(ref.proc(), context)}) {
     if (callee->functionResult) {
       if (const Procedure *
           proc{callee->functionResult->IsProcedurePointer()}) {

flang/lib/Evaluate/check-expression.cpp

 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/check-expression.h"
+#include "flang/Evaluate/characteristics.h"
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Evaluate/type.h"

   using Base::operator();
 
   bool operator()(const TypeParamInquiry &inq) const {
-    return IsKindTypeParameter(inq.parameter());
+    return semantics::IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{symbol.GetUltimate()};

 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
 template bool IsConstantExpr(const StructureConstructor &);
 
+// IsActuallyConstant()
+struct IsActuallyConstantHelper {
+  template <typename A> bool operator()(const A &) { return false; }
+  template <typename T> bool operator()(const Constant<T> &) { return true; }
+  template <typename T> bool operator()(const Parentheses<T> &x) {
+    return (*this)(x.left());
+  }
+  template <typename T> bool operator()(const Expr<T> &x) {
+    return std::visit([=](const auto &y) { return (*this)(y); }, x.u);
+  }
+  template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
+  template <typename A> bool operator()(const std::optional<A> &x) {
+    return x && (*this)(*x);
+  }
+};
+
+template <typename A> bool IsActuallyConstant(const A &x) {
+  return IsActuallyConstantHelper{}(x);
+}
+
+template bool IsActuallyConstant(const Expr<SomeType> &);
+
 // Object pointer initialization checking predicate IsInitialDataTarget().
 // This code determines whether an expression is allowable as the static
 // data address used to initialize a pointer with "=> x".  See C765.

   }
 }
 
+class ScalarExpansionVisitor : public AnyTraverse<ScalarExpansionVisitor,
+                                   std::optional<Expr<SomeType>>> {
+public:
+  using Result = std::optional<Expr<SomeType>>;
+  using Base = AnyTraverse<ScalarExpansionVisitor, Result>;
+  ScalarExpansionVisitor(
+      ConstantSubscripts &&shape, std::optional<ConstantSubscripts> &&lb)
+      : Base{*this}, shape_{std::move(shape)}, lbounds_{std::move(lb)} {}
+  using Base::operator();
+  template <typename T> Result operator()(const Constant<T> &x) {
+    auto expanded{x.Reshape(std::move(shape_))};
+    if (lbounds_) {
+      expanded.set_lbounds(std::move(*lbounds_));
+    }
+    return AsGenericExpr(std::move(expanded));
+  }
+
+private:
+  ConstantSubscripts shape_;
+  std::optional<ConstantSubscripts> lbounds_;
+};
+
+// Converts, folds, and then checks type, rank, and shape of an
+// initialization expression for a named constant, a non-pointer
+// variable static initializatio, a component default initializer,
+// a type parameter default value, or instantiated type parameter value.
+std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
+    Expr<SomeType> &&x, FoldingContext &context,
+    const semantics::Scope *instantiation) {
+  CHECK(!IsPointer(symbol));
+  if (auto symTS{
+          characteristics::TypeAndShape::Characterize(symbol, context)}) {
+    auto xType{x.GetType()};
+    if (auto converted{ConvertToType(symTS->type(), std::move(x))}) {
+      auto folded{Fold(context, std::move(*converted))};
+      if (IsActuallyConstant(folded)) {
+        int symRank{GetRank(symTS->shape())};
+        if (IsImpliedShape(symbol)) {
+          if (folded.Rank() == symRank) {
+            return {std::move(folded)};
+          } else {
+            context.messages().Say(
+                "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
+                symbol.name(), symRank, folded.Rank());
+          }
+        } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
+          if (folded.Rank() == 0 && symRank > 0) {
+            return ScalarConstantExpander{std::move(*extents),
+                AsConstantExtents(
+                    context, GetLowerBounds(context, NamedEntity{symbol}))}
+                .Expand(std::move(folded));
+          } else if (auto resultShape{GetShape(context, folded)}) {
+            if (CheckConformance(context.messages(), symTS->shape(),
+                    *resultShape, "initialized object",
+                    "initialization expression", false, false)) {
+              return {std::move(folded)};
+            }
+          }
+        } else if (IsNamedConstant(symbol)) {
+          if (IsExplicitShape(symbol)) {
+            context.messages().Say(
+                "Named constant '%s' array must have constant shape"_err_en_US,
+                symbol.name());
+          } else {
+            // Declaration checking handles other cases
+          }
+        } else {
+          context.messages().Say(
+              "Shape of initialized object '%s' must be constant"_err_en_US,
+              symbol.name());
+        }
+      } else if (IsErrorExpr(folded)) {
+      } else if (IsLenTypeParameter(symbol)) {
+        return {std::move(folded)};
+      } else if (IsKindTypeParameter(symbol)) {
+        if (instantiation) {
+          context.messages().Say(
+              "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
+              symbol.name(), folded.AsFortran());
+        } else {
+          return {std::move(folded)};
+        }
+      } else if (IsNamedConstant(symbol)) {
+        context.messages().Say(
+            "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
+            symbol.name(), folded.AsFortran());
+      } else {
+        context.messages().Say(
+            "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
+            symbol.name(), folded.AsFortran());
+      }
+    } else if (xType) {
+      context.messages().Say(
+          "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
+          symbol.name(), xType->AsFortran());
+    } else {
+      context.messages().Say(
+          "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
+          symbol.name());
+    }
+  }
+  return std::nullopt;
+}
+
 // Specification expression validation (10.1.11(2), C1010)
 class CheckSpecificationExprHelper
     : public AnyTraverse<CheckSpecificationExprHelper,

   using Result = std::optional<std::string>;
   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
   explicit CheckSpecificationExprHelper(
-      const semantics::Scope &s, const IntrinsicProcTable &table)
-      : Base{*this}, scope_{s}, table_{table} {}
+      const semantics::Scope &s, FoldingContext &context)
+      : Base{*this}, scope_{s}, context_{context} {}
   using Base::operator();
 
   Result operator()(const ProcedureDesignator &) const {

     } else {
       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
       if (scope_.IsDerivedType()) { // C750, C754
-        if ((table_.IsIntrinsic(intrin.name) &&
+        if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
                 badIntrinsicsForComponents_.find(intrin.name) !=
                     badIntrinsicsForComponents_.end()) ||
             IsProhibitedFunction(intrin.name)) {

               "' not allowed for derived type components or type parameter"
               " values";
         }
-        if (table_.GetIntrinsicClass(intrin.name) ==
+        if (context_.intrinsics().GetIntrinsicClass(intrin.name) ==
                 IntrinsicClass::inquiryFunction &&
             !IsConstantExpr(x)) {
           return "non-constant reference to inquiry intrinsic '"s +

 
 private:
   const semantics::Scope &scope_;
-  const IntrinsicProcTable &table_;
+  FoldingContext &context_;
   const std::set<std::string> badIntrinsicsForComponents_{
       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
   static bool IsProhibitedFunction(std::string name) { return false; }
 };
 
 template <typename A>
-void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
-    const semantics::Scope &scope, const IntrinsicProcTable &table) {
-  if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) {
-    messages.Say("Invalid specification expression: %s"_err_en_US, *why);
+void CheckSpecificationExpr(
+    const A &x, const semantics::Scope &scope, FoldingContext &context) {
+  if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
+    context.messages().Say(
+        "Invalid specification expression: %s"_err_en_US, *why);
   }
 }
 
-template void CheckSpecificationExpr(const Expr<SomeType> &,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
-template void CheckSpecificationExpr(const Expr<SomeInteger> &,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
-template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+template void CheckSpecificationExpr(
+    const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
+template void CheckSpecificationExpr(
+    const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
+template void CheckSpecificationExpr(
+    const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+    const semantics::Scope &, FoldingContext &);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
-    parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &);
+    const semantics::Scope &, FoldingContext &);
 template void CheckSpecificationExpr(
-    const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &);
+    const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
+    FoldingContext &);
 
 // IsSimplyContiguous() -- 9.5.4
 class IsSimplyContiguousHelper

 public:
   using Result = std::optional<bool>; // tri-state
   using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
-  explicit IsSimplyContiguousHelper(const IntrinsicProcTable &t)
-      : Base{*this}, table_{t} {}
+  explicit IsSimplyContiguousHelper(FoldingContext &c)
+      : Base{*this}, context_{c} {}
   using Base::operator();
 
   Result operator()(const semantics::Symbol &symbol) const {

 
   template <typename T> Result operator()(const FunctionRef<T> &x) const {
     if (auto chars{
-            characteristics::Procedure::Characterize(x.proc(), table_)}) {
+            characteristics::Procedure::Characterize(x.proc(), context_)}) {
       if (chars->functionResult) {
         const auto &result{*chars->functionResult};
         return !result.IsProcedurePointer() &&

     return rank;
   }
 
-  const IntrinsicProcTable &table_;
+  FoldingContext &context_;
 };
 
 template <typename A>
-bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
+bool IsSimplyContiguous(const A &x, FoldingContext &context) {
   if (IsVariable(x)) {
-    auto known{IsSimplyContiguousHelper{table}(x)};
+    auto known{IsSimplyContiguousHelper{context}(x)};
     return known && *known;
   } else {
     return true; // not a variable
   }
 }
 
-template bool IsSimplyContiguous(
-    const Expr<SomeType> &, const IntrinsicProcTable &);
+template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &);
+
+// IsErrorExpr()
+struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
+  using Result = bool;
+  using Base = AnyTraverse<IsErrorExprHelper, Result>;
+  IsErrorExprHelper() : Base{*this} {}
+  using Base::operator();
+
+  bool operator()(const SpecificIntrinsic &x) {
+    return x.name == IntrinsicProcTable::InvalidName;
+  }
+};
+
+template <typename A> bool IsErrorExpr(const A &x) {
+  return IsErrorExprHelper{}(x);
+}
+
+template bool IsErrorExpr(const Expr<SomeType> &);
 
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-implementation.h

 template <typename T> class Folder {
 public:
   explicit Folder(FoldingContext &c) : context_{c} {}
-  std::optional<Expr<T>> GetNamedConstantValue(const Symbol &);
-  std::optional<Constant<T>> GetFoldedNamedConstantValue(const Symbol &);
+  std::optional<Constant<T>> GetNamedConstant(const Symbol &);
   std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
       const std::vector<Constant<SubscriptInteger>> &subscripts);
   std::optional<Constant<T>> ApplyComponent(Constant<SomeDerived> &&,

 Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
 
 template <typename T>
-std::optional<Expr<T>> Folder<T>::GetNamedConstantValue(const Symbol &symbol0) {
+std::optional<Constant<T>> Folder<T>::GetNamedConstant(const Symbol &symbol0) {
   const Symbol &symbol{ResolveAssociations(symbol0)};
   if (IsNamedConstant(symbol)) {
     if (const auto *object{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-      if (object->initWasValidated()) {
-        const auto *constant{UnwrapConstantValue<T>(object->init())};
-        return Expr<T>{DEREF(constant)};
+      if (const auto *constant{UnwrapConstantValue<T>(object->init())}) {
+        return *constant;
       }
-      if (const auto &init{object->init()}) {
-        if (auto dyType{DynamicType::From(symbol)}) {
-          semantics::ObjectEntityDetails *mutableObject{
-              const_cast<semantics::ObjectEntityDetails *>(object)};
-          auto converted{
-              ConvertToType(*dyType, std::move(mutableObject->init().value()))};
-          // Reset expression now to prevent infinite loops if the init
-          // expression depends on symbol itself.
-          mutableObject->set_init(std::nullopt);
-          if (converted) {
-            *converted = Fold(context_, std::move(*converted));
-            auto *unwrapped{UnwrapExpr<Expr<T>>(*converted)};
-            CHECK(unwrapped);
-            if (auto *constant{UnwrapConstantValue<T>(*unwrapped)}) {
-              if (symbol.Rank() > 0) {
-                if (constant->Rank() == 0) {
-                  // scalar expansion
-                  if (auto extents{GetConstantExtents(context_, symbol)}) {
-                    *constant = constant->Reshape(std::move(*extents));
-                    CHECK(constant->Rank() == symbol.Rank());
-                  }
-                }
-                if (constant->Rank() == symbol.Rank()) {
-                  NamedEntity base{symbol};
-                  if (auto lbounds{AsConstantExtents(
-                          context_, GetLowerBounds(context_, base))}) {
-                    constant->set_lbounds(*std::move(lbounds));
-                  }
-                }
-              }
-              mutableObject->set_init(AsGenericExpr(Expr<T>{*constant}));
-              if (auto constShape{GetShape(context_, *constant)}) {
-                if (auto symShape{GetShape(context_, symbol)}) {
-                  if (CheckConformance(context_.messages(), *constShape,
-                          *symShape, "initialization expression",
-                          "PARAMETER")) {
-                    mutableObject->set_initWasValidated();
-                    return std::move(*unwrapped);
-                  }
-                } else {
-                  context_.messages().Say(symbol.name(),
-                      "Could not determine the shape of the PARAMETER"_err_en_US);
-                }
-              } else {
-                context_.messages().Say(symbol.name(),
-                    "Could not determine the shape of the initialization expression"_err_en_US);
-              }
-              mutableObject->set_init(std::nullopt);
-            } else {
-              context_.messages().Say(symbol.name(),
-                  "Initialization expression for PARAMETER '%s' (%s) cannot be computed as a constant value"_err_en_US,
-                  symbol.name(), unwrapped->AsFortran());
-            }
-          } else {
-            context_.messages().Say(symbol.name(),
-                "Initialization expression for PARAMETER '%s' (%s) cannot be converted to its type (%s)"_err_en_US,
-                symbol.name(), init->AsFortran(), dyType->AsFortran());
-          }
-        }
-      }
-    }
-  }
-  return std::nullopt;
-}
-
-template <typename T>
-std::optional<Constant<T>> Folder<T>::GetFoldedNamedConstantValue(
-    const Symbol &symbol) {
-  if (auto value{GetNamedConstantValue(symbol)}) {
-    Expr<T> folded{Fold(context_, std::move(*value))};
-    if (const Constant<T> *value{UnwrapConstantValue<T>(folded)}) {
-      return *value;
     }
   }
   return std::nullopt;

   if (Component * component{aRef.base().UnwrapComponent()}) {
     return GetConstantComponent(*component, &subscripts);
   } else if (std::optional<Constant<T>> array{
-                 GetFoldedNamedConstantValue(aRef.base().GetLastSymbol())}) {
+                 GetNamedConstant(aRef.base().GetLastSymbol())}) {
     return ApplySubscripts(*array, subscripts);
   } else {
     return std::nullopt;

   if (std::optional<Constant<SomeDerived>> structures{std::visit(
           common::visitors{
               [&](const Symbol &symbol) {
-                return Folder<SomeDerived>{context_}
-                    .GetFoldedNamedConstantValue(symbol);
+                return Folder<SomeDerived>{context_}.GetNamedConstant(symbol);
               },
               [&](ArrayRef &aRef) {
                 return Folder<SomeDerived>{context_}.Folding(aRef);

   return std::visit(
       common::visitors{
           [&](SymbolRef &&symbol) {
-            if (auto constant{GetFoldedNamedConstantValue(*symbol)}) {
+            if (auto constant{GetNamedConstant(*symbol)}) {
               return Expr<T>{std::move(*constant)};
             }
             return Expr<T>{std::move(designator)};

flang/lib/Evaluate/fold-logical.cpp

   } else if (name == "is_contiguous") {
     if (args.at(0)) {
       if (auto *expr{args[0]->UnwrapExpr()}) {
-        if (IsSimplyContiguous(*expr, context.intrinsics())) {
+        if (IsSimplyContiguous(*expr, context)) {
           return Expr<T>{true};
         }
       }

flang/lib/Evaluate/fold.cpp

       ss.u);
 }
 
-// TODO: Put this in a more central location if it would be useful elsewhere
-class ScalarConstantExpander {
-public:
-  explicit ScalarConstantExpander(ConstantSubscripts &extents)
-      : extents_{extents} {}
-
-  template <typename A> A Expand(A &&x) const {
-    return std::move(x); // default case
-  }
-  template <typename T> Constant<T> Expand(Constant<T> &&x) {
-    return x.Reshape(std::move(extents_));
-  }
-  template <typename T> Expr<T> Expand(Expr<T> &&x) {
-    return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
-        std::move(x.u));
-  }
-
-private:
-  ConstantSubscripts &extents_;
-};
-
 Expr<SomeDerived> FoldOperation(
     FoldingContext &context, StructureConstructor &&structure) {
   StructureConstructor ctor{structure.derivedTypeSpec()};
   bool constantExtents{true};
   for (auto &&[symbol, value] : std::move(structure)) {
     auto expr{Fold(context, std::move(value.value()))};
-    if (!IsProcedurePointer(symbol)) {
+    if (!IsPointer(symbol)) {
+      bool ok{false};
       if (auto valueShape{GetConstantExtents(context, expr)}) {
-        if (!IsPointer(symbol)) {
-          if (auto componentShape{GetConstantExtents(context, symbol)}) {
-            if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {
-              expr = ScalarConstantExpander{*componentShape}.Expand(
-                  std::move(expr));
-              constantExtents = constantExtents && expr.Rank() > 0;
-            } else {
-              constantExtents =
-                  constantExtents && *valueShape == *componentShape;
-            }
+        if (auto componentShape{GetConstantExtents(context, symbol)}) {
+          if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {
+            expr = ScalarConstantExpander{std::move(*componentShape)}.Expand(
+                std::move(expr));
+            ok = expr.Rank() > 0;
           } else {
-            constantExtents = false;
+            ok = *valueShape == *componentShape;
           }
         }
-      } else {
+      }
+      if (!ok) {
         constantExtents = false;
       }
     }

flang/lib/Evaluate/intrinsics.cpp

 
 private:
   DynamicType GetSpecificType(const TypePattern &) const;
-  SpecificCall HandleNull(
-      ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const;
+  SpecificCall HandleNull(ActualArguments &, FoldingContext &) const;
   std::optional<SpecificCall> HandleC_F_Pointer(
       ActualArguments &, FoldingContext &) const;
 

 
 // The NULL() intrinsic is a special case.
 SpecificCall IntrinsicProcTable::Implementation::HandleNull(
-    ActualArguments &arguments, FoldingContext &context,
-    const IntrinsicProcTable &intrinsics) const {
+    ActualArguments &arguments, FoldingContext &context) const {
   static const char *const keywords[]{"mold", nullptr};
   if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
       arguments[0]) {

           const Symbol *last{GetLastSymbol(*mold)};
           CHECK(last);
           auto procPointer{
-              characteristics::Procedure::Characterize(*last, intrinsics)};
+              characteristics::Procedure::Characterize(*last, context)};
           // procPointer is null if there was an error with the analysis
           // associated with the procedure pointer
           if (procPointer) {

   }
 }
 
-static bool CheckAssociated(SpecificCall &call,
-    parser::ContextualMessages &messages,
-    const IntrinsicProcTable &intrinsics) {
+static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   if (const auto &pointerArg{call.arguments[0]}) {
     if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
       if (const Symbol * pointerSymbol{GetLastSymbol(*pointerExpr)}) {
         if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) {
-          AttachDeclaration(
-              messages.Say("POINTER= argument of ASSOCIATED() must be a "
+          AttachDeclaration(context.messages().Say(
+                                "POINTER= argument of ASSOCIATED() must be a "
                                 "POINTER"_err_en_US),
               *pointerSymbol);
         } else {
           const auto pointerProc{characteristics::Procedure::Characterize(
-              *pointerSymbol, intrinsics)};
+              *pointerSymbol, context)};
           if (const auto &targetArg{call.arguments[1]}) {
             if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
               std::optional<characteristics::Procedure> targetProc{

                       std::get_if<ProcedureRef>(&targetExpr->u)}) {
                 if (auto targetRefedChars{
                         characteristics::Procedure::Characterize(
-                            *targetProcRef, intrinsics)}) {
+                            *targetProcRef, context)}) {
                   targetProc = *targetRefedChars;
                   targetName = targetProcRef->proc().GetName() + "()";
                   isCall = true;

               } else if (targetSymbol && !targetProc) {
                 // proc that's not a call
                 targetProc = characteristics::Procedure::Characterize(
-                    *targetSymbol, intrinsics);
+                    *targetSymbol, context);
                 targetName = targetSymbol->name().ToString();
               }
 

                           CheckProcCompatibility(
                               isCall, pointerProc, &*targetProc)}) {
                     AttachDeclaration(
-                        messages.Say(std::move(*msg),
+                        context.messages().Say(std::move(*msg),
                             "pointer '" + pointerSymbol->name().ToString() +
                                 "'",
                             targetName),

                   // procedure pointer and object target
                   if (!IsNullPointer(*targetExpr)) {
                     AttachDeclaration(
-                        messages.Say(
+                        context.messages().Say(
                             "POINTER= argument '%s' is a procedure "
                             "pointer but the TARGET= argument '%s' is not a "
                             "procedure or procedure pointer"_err_en_US,

               } else if (targetProc) {
                 // object pointer and procedure target
                 AttachDeclaration(
-                    messages.Say("POINTER= argument '%s' is an object pointer "
-                                 "but the TARGET= argument '%s' is a "
-                                 "procedure designator"_err_en_US,
+                    context.messages().Say(
+                        "POINTER= argument '%s' is an object pointer "
+                        "but the TARGET= argument '%s' is a "
+                        "procedure designator"_err_en_US,
                         pointerSymbol->name(), targetName),
                     *pointerSymbol);
               } else {

                           targetSymbol->attrs().test(
                               semantics::Attr::TARGET))) {
                     AttachDeclaration(
-                        messages.Say("TARGET= argument '%s' must have either "
-                                     "the POINTER or the TARGET "
-                                     "attribute"_err_en_US,
+                        context.messages().Say(
+                            "TARGET= argument '%s' must have either "
+                            "the POINTER or the TARGET "
+                            "attribute"_err_en_US,
                             targetName),
                         *targetSymbol);
                   }

     ok = false;
   }
   if (!ok) {
-    messages.Say(
+    context.messages().Say(
         "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
   }
   return ok;
 }
 
 // Applies any semantic checks peculiar to an intrinsic.
-static bool ApplySpecificChecks(SpecificCall &call,
-    parser::ContextualMessages &messages,
-    const IntrinsicProcTable &intrinsics) {
+static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {

       }
     }
     if (!ok) {
-      messages.Say(
+      context.messages().Say(
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } else if (name == "associated") {
-    return CheckAssociated(call, messages, intrinsics);
+    return CheckAssociated(call, context);
   } else if (name == "loc") {
     if (const auto &arg{call.arguments[0]}) {
       ok = arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr());
     }
     if (!ok) {
-      messages.Say(
+      context.messages().Say(
           "Argument of LOC() must be an object or procedure"_err_en_US);
     }
   } else if (name == "present") {

       }
     }
     if (!ok) {
-      messages.Say(
+      context.messages().Say(
           "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
     }
   }

     }
   } else {
     if (call.name == "null") {
-      return HandleNull(arguments, context, intrinsics);
+      return HandleNull(arguments, context);
     }
   }
 

   for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
     if (auto specificCall{
             matchOrBufferMessages(*iter->second, genericBuffer)}) {
-      ApplySpecificChecks(*specificCall, context.messages(), intrinsics);
+      ApplySpecificChecks(*specificCall, context);
       return specificCall;
     }
   }

flang/lib/Evaluate/shape.cpp

 
 bool IsImpliedShape(const Symbol &symbol0) {
   const Symbol &symbol{ResolveAssociations(symbol0)};
-  if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (symbol.attrs().test(semantics::Attr::PARAMETER) && details->init()) {
-      return details->shape().IsImpliedShape();
-    }
-  }
-  return false;
+  const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+  return symbol.attrs().test(semantics::Attr::PARAMETER) && details &&
+      details->shape().IsImpliedShape();
 }
 
 bool IsExplicitShape(const Symbol &symbol0) {

 // Check conformance of the passed shapes.  Only return true if we can verify
 // that they conform
 bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
-    const Shape &right, const char *leftIs, const char *rightIs) {
+    const Shape &right, const char *leftIs, const char *rightIs,
+    bool leftScalarExpandable, bool rightScalarExpandable) {
   int n{GetRank(left)};
+  if (n == 0 && leftScalarExpandable) {
+    return true;
+  }
   int rn{GetRank(right)};
-  if (n != 0 && rn != 0) {
-    if (n != rn) {
-      messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
-          leftIs, n, rightIs, rn);
+  if (rn == 0 && rightScalarExpandable) {
+    return true;
+  }
+  if (n != rn) {
+    messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
+        leftIs, n, rightIs, rn);
+    return false;
+  }
+  for (int j{0}; j < n; ++j) {
+    auto leftDim{ToInt64(left[j])};
+    auto rightDim{ToInt64(right[j])};
+    if (!leftDim || !rightDim) {
+      return false;
+    }
+    if (*leftDim != *rightDim) {
+      messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
+                   "but %4$s has extent %5$jd"_err_en_US,
+          j + 1, leftIs, *leftDim, rightIs, *rightDim);
       return false;
-    } else {
-      for (int j{0}; j < n; ++j) {
-        auto leftDim{ToInt64(left[j])};
-        auto rightDim{ToInt64(right[j])};
-        if (!leftDim || !rightDim) {
-          return false;
-        }
-        if (*leftDim != *rightDim) {
-          messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
-                       "but %4$s has extent %5$jd"_err_en_US,
-              j + 1, leftIs, *leftDim, rightIs, *rightDim);
-          return false;
-        }
-      }
     }
   }
   return true;

flang/lib/Evaluate/tools.cpp

 
 parser::Message *AttachDeclaration(
     parser::Message *message, const Symbol &symbol) {
-  if (message) {
-    AttachDeclaration(*message, symbol);
-  }
-  return message;
+  return message ? AttachDeclaration(*message, symbol) : nullptr;
 }
 
 class FindImpureCallHelper

   using Base = AnyTraverse<FindImpureCallHelper, Result>;
 
 public:
-  explicit FindImpureCallHelper(const IntrinsicProcTable &intrinsics)
-      : Base{*this}, intrinsics_{intrinsics} {}
+  explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
   using Base::operator();
   Result operator()(const ProcedureRef &call) const {
-    if (auto chars{characteristics::Procedure::Characterize(
-            call.proc(), intrinsics_)}) {
+    if (auto chars{
+            characteristics::Procedure::Characterize(call.proc(), context_)}) {
       if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
         return (*this)(call.arguments());
       }

   }
 
 private:
-  const IntrinsicProcTable &intrinsics_;
+  FoldingContext &context_;
 };
 
 std::optional<std::string> FindImpureCall(
-    const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
-  return FindImpureCallHelper{intrinsics}(expr);
+    FoldingContext &context, const Expr<SomeType> &expr) {
+  return FindImpureCallHelper{context}(expr);
 }
 std::optional<std::string> FindImpureCall(
-    const IntrinsicProcTable &intrinsics, const ProcedureRef &proc) {
-  return FindImpureCallHelper{intrinsics}(proc);
+    FoldingContext &context, const ProcedureRef &proc) {
+  return FindImpureCallHelper{context}(proc);
 }
 
 // Compare procedure characteristics for equality except that lhs may be

           symbol.get<ProcEntityDetails>().isFuncResult());
 }
 
+bool IsKindTypeParameter(const Symbol &symbol) {
+  const auto *param{symbol.detailsIf<TypeParamDetails>()};
+  return param && param->attr() == common::TypeParamAttr::Kind;
+}
+
+bool IsLenTypeParameter(const Symbol &symbol) {
+  const auto *param{symbol.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/Evaluate/type.cpp

   }
 }
 
-bool IsKindTypeParameter(const semantics::Symbol &symbol) {
-  const auto *param{symbol.detailsIf<semantics::TypeParamDetails>()};
-  return param && param->attr() == common::TypeParamAttr::Kind;
-}
-
 // Do the kind type parameters of type1 have the same values as the
 // corresponding kind type parameters of type2?
 static bool AreKindCompatible(const semantics::DerivedTypeSpec &type1,

flang/lib/Parser/message.cpp

   text += ToString();
   const AllSources &sources{allCooked.allSources()};
   sources.EmitMessage(o, provenanceRange, text, echoSourceLine);
-  if (attachmentIsContext_) {
-    for (const Message *context{attachment_.get()}; context;
-         context = context->attachment_.get()) {
-      std::optional<ProvenanceRange> contextProvenance{
-          context->GetProvenanceRange(allCooked)};
+  bool isContext{attachmentIsContext_};
+  for (const Message *attachment{attachment_.get()}; attachment;
+       attachment = attachment->attachment_.get()) {
+    text.clear();
+    if (isContext) {
       text = "in the context: ";
-      text += context->ToString();
-      // TODO: don't echo the source lines of a context when it's the
-      // same line (or maybe just never echo source for context)
-      sources.EmitMessage(o, contextProvenance, text,
-          echoSourceLine && contextProvenance != provenanceRange);
-      provenanceRange = contextProvenance;
-    }
-  } else {
-    for (const Message *attachment{attachment_.get()}; attachment;
-         attachment = attachment->attachment_.get()) {
-      sources.EmitMessage(o, attachment->GetProvenanceRange(allCooked),
-          attachment->ToString(), echoSourceLine);
     }
+    text += attachment->ToString();
+    sources.EmitMessage(
+        o, attachment->GetProvenanceRange(allCooked), text, echoSourceLine);
+    isContext = attachment->attachmentIsContext_;
   }
 }
 

   if (!attachment_) {
     attachment_ = m;
   } else {
+    if (attachment_->references() > 1) {
+      // Don't attach to a shared context attachment; copy it first.
+      attachment_ = new Message{*attachment_};
+    }
     attachment_->Attach(m);
   }
   return *this;

flang/lib/Parser/parse-tree.cpp

 llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Name &x) {
   return os << x.ToString();
 }
-
 } // namespace Fortran::parser

flang/lib/Semantics/check-call.cpp

       // Sequence association (15.5.2.11) applies -- rank need not match
       // if the actual argument is an array or array element designator.
     } else {
+      // Let CheckConformance accept scalars; storage association
+      // cases are checked here below.
       CheckConformance(messages, dummy.type.shape(), actualType.shape(),
-          "dummy argument", "actual argument");
+          "dummy argument", "actual argument", true, true);
     }
   } else {
     const auto &len{actualType.LEN()};

       dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
   bool dummyIsContiguous{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
-  bool actualIsContiguous{IsSimplyContiguous(actual, context.intrinsics())};
+  bool actualIsContiguous{IsSimplyContiguous(actual, context)};
   bool dummyIsAssumedRank{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedRank)};
   bool dummyIsAssumedShape{dummy.type.attrs().test(

flang/lib/Semantics/check-declarations.h

 #define FORTRAN_SEMANTICS_CHECK_DECLARATIONS_H_
 namespace Fortran::semantics {
 class SemanticsContext;
-class DerivedTypeSpec;
 void CheckDeclarations(SemanticsContext &);
-void CheckInstantiatedDerivedType(SemanticsContext &, const DerivedTypeSpec &);
 } // namespace Fortran::semantics
 #endif

flang/lib/Semantics/check-declarations.cpp

 // Static declaration checking
 
 #include "check-declarations.h"
+#include "pointer-assignment.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"

   void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
   void Check(const Symbol &);
   void Check(const Scope &);
-  void CheckInitialization(const Symbol &);
   const Procedure *Characterize(const Symbol &);
 
 private:
   template <typename A> void CheckSpecExpr(const A &x) {
-    evaluate::CheckSpecificationExpr(
-        x, messages_, DEREF(scope_), context_.intrinsics());
+    evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_);
   }
   void CheckValue(const Symbol &, const DerivedTypeSpec *);
   void CheckVolatile(

       const Symbol &proc, const Symbol *interface, const WithPassArg &);
   void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
   void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
+  void CheckPointerInitialization(const Symbol &);
   void CheckArraySpec(const Symbol &, const ArraySpec &);
   void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
   void CheckSubprogram(const Symbol &, const SubprogramDetails &);

     }
   }
   bool IsResultOkToDiffer(const FunctionResult &);
-  bool IsScopePDT() const {
-    return scope_ && scope_->IsParameterizedDerivedType();
-  }
 
   SemanticsContext &context_;
   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
   parser::ContextualMessages &messages_{foldingContext_.messages()};
   const Scope *scope_{nullptr};
+  bool scopeIsUninstantiatedPDT_{false};
   // This symbol is the one attached to the innermost enclosing scope
   // that has a symbol.
   const Symbol *innermostSymbol_{nullptr};

   if (context_.HasError(symbol)) {
     return;
   }
-  const DeclTypeSpec *type{symbol.GetType()};
-  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   auto restorer{messages_.SetLocation(symbol.name())};
   context_.set_location(symbol.name());
+  const DeclTypeSpec *type{symbol.GetType()};
+  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   bool isAssociated{symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()};
   if (symbol.attrs().test(Attr::VOLATILE)) {
     CheckVolatile(symbol, isAssociated, derived);

       }
     }
   }
-  bool badInit{false};
-  if (symbol.owner().kind() != Scope::Kind::DerivedType &&
-      IsInitialized(symbol, true /*ignore DATA, already caught*/)) { // C808
+  if (IsInitialized(symbol, true /* ignore DATA inits */)) { // C808
+    CheckPointerInitialization(symbol);
     if (IsAutomatic(symbol)) {
-      badInit = true;
-      messages_.Say("An automatic variable must not be initialized"_err_en_US);
+      messages_.Say(
+          "An automatic variable or component must not be initialized"_err_en_US);
     } else if (IsDummy(symbol)) {
-      badInit = true;
       messages_.Say("A dummy argument must not be initialized"_err_en_US);
     } else if (IsFunctionResult(symbol)) {
-      badInit = true;
       messages_.Say("A function result must not be initialized"_err_en_US);
     } else if (IsInBlankCommon(symbol)) {
-      badInit = true;
       messages_.Say(
           "A variable in blank COMMON should not be initialized"_en_US);
     }
   }
-  if (symbol.owner().kind() == Scope::Kind::BlockData &&
-      IsInitialized(symbol)) {
+  if (symbol.owner().kind() == Scope::Kind::BlockData) {
     if (IsAllocatable(symbol)) {
       messages_.Say(
           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
-    } else if (!FindCommonBlockContaining(symbol)) {
+    } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
       messages_.Say(
           "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
     }

           symbol.name());
     }
   }
-  if (!badInit && !IsScopePDT()) {
-    CheckInitialization(symbol);
-  }
 }
 
-void CheckHelper::CheckInitialization(const Symbol &symbol) {
-  const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
-  if (!details) {
-    // not an object
-  } else if (const auto &init{details->init()}) { // 8.2 para 4
-    int initRank{init->Rank()};
-    int symbolRank{details->shape().Rank()};
-    if (IsPointer(symbol)) {
-      // Pointer initialization rank/shape errors are caught earlier in
-      // name resolution
-    } else if (details->shape().IsImpliedShape() ||
-        details->shape().IsDeferredShape()) {
-      if (symbolRank != initRank) {
-        messages_.Say(
-            "%s-shape array '%s' has rank %d, but its initializer has rank %d"_err_en_US,
-            details->shape().IsImpliedShape() ? "Implied" : "Deferred",
-            symbol.name(), symbolRank, initRank);
+void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
+  if (IsPointer(symbol) && !context_.HasError(symbol) &&
+      !scopeIsUninstantiatedPDT_) {
+    if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+      if (object->init()) { // C764, C765; C808
+        if (auto dyType{evaluate::DynamicType::From(symbol)}) {
+          if (auto designator{evaluate::TypedWrapper<evaluate::Designator>(
+                  *dyType, evaluate::DataRef{symbol})}) {
+            auto restorer{messages_.SetLocation(symbol.name())};
+            context_.set_location(symbol.name());
+            CheckInitialTarget(foldingContext_, *designator, *object->init());
+          }
+        }
       }
-    } else if (symbolRank != initRank && initRank != 0) {
-      // Pointer initializer rank errors are caught elsewhere
-      messages_.Say(
-          "'%s' has rank %d, but its initializer has rank %d"_err_en_US,
-          symbol.name(), symbolRank, initRank);
-    } else if (auto symbolShape{evaluate::GetShape(foldingContext_, symbol)}) {
-      if (!evaluate::AsConstantExtents(foldingContext_, *symbolShape)) {
-        // C762
-        messages_.Say(
-            "Shape of '%s' is not implied, deferred, nor constant"_err_en_US,
-            symbol.name());
-      } else if (auto initShape{evaluate::GetShape(foldingContext_, *init)}) {
-        if (initRank == symbolRank) {
-          evaluate::CheckConformance(
-              messages_, *symbolShape, *initShape, "object", "initializer");
+    } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+      if (proc->init() && *proc->init()) {
+        // C1519 - must be nonelemental external or module procedure,
+        // or an unrestricted specific intrinsic function.
+        const Symbol &ultimate{(*proc->init())->GetUltimate()};
+        if (ultimate.attrs().test(Attr::INTRINSIC)) {
+        } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
+            ultimate.owner().kind() != Scope::Kind::Module) {
+          context_.Say("Procedure pointer '%s' initializer '%s' is neither "
+                       "an external nor a module procedure"_err_en_US,
+              symbol.name(), ultimate.name());
+        } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
+          context_.Say("Procedure pointer '%s' cannot be initialized with the "
+                       "elemental procedure '%s"_err_en_US,
+              symbol.name(), ultimate.name());
         } else {
-          CHECK(initRank == 0);
-          // TODO: expand scalar now, or in lowering?
+          // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
         }
       }
     }

     }
   } else if (IsNamedConstant(symbol)) {
     if (!isExplicit && !isImplied) {
-      msg = "Named constant '%s' array must have explicit or"
+      msg = "Named constant '%s' array must have constant or"
             " implied shape"_err_en_US;
     }
   } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {

     CheckPassArg(symbol, details.interface().symbol(), details);
   }
   if (symbol.attrs().test(Attr::POINTER)) {
+    CheckPointerInitialization(symbol);
     if (const Symbol * interface{details.interface().symbol()}) {
       if (interface->attrs().test(Attr::ELEMENTAL) &&
           !interface->attrs().test(Attr::INTRINSIC)) {

     } else if (subprogramDetails && details.isFunction() &&
         subprogramDetails->isFunction()) {
       auto result{FunctionResult::Characterize(
-          details.result(), context_.intrinsics())};
+          details.result(), context_.foldingContext())};
       auto subpResult{FunctionResult::Characterize(
-          subprogramDetails->result(), context_.intrinsics())};
+          subprogramDetails->result(), context_.foldingContext())};
       if (result && subpResult && *result != *subpResult &&
           (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
         error =

     ok = false;
   } else { // check that all LEN type parameters are assumed
     for (auto ref : OrderParameterDeclarations(derivedType)) {
-      if (const auto *paramDetails{ref->detailsIf<TypeParamDetails>()}) {
-        if (paramDetails->attr() == common::TypeParamAttr::Len) {
-          const auto *value{
-              ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
-          if (!value || !value->isAssumed()) {
-            SayWithDeclaration(*errSym, finalName,
-                "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
-                subroutine.name(), derivedType.name(), ref->name());
-            ok = false;
-          }
+      if (IsLenTypeParameter(*ref)) {
+        const auto *value{
+            ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
+        if (!value || !value->isAssumed()) {
+          SayWithDeclaration(*errSym, finalName,
+              "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
+              subroutine.name(), derivedType.name(), ref->name());
+          ok = false;
         }
       }
     }

   auto it{characterizeCache_.find(symbol)};
   if (it == characterizeCache_.end()) {
     auto pair{characterizeCache_.emplace(SymbolRef{symbol},
-        Procedure::Characterize(symbol, context_.intrinsics()))};
+        Procedure::Characterize(symbol, context_.foldingContext()))};
     it = pair.first;
   }
   return common::GetPtrFromOptional(it->second);

   common::Restorer<const Symbol *> restorer{innermostSymbol_};
   if (const Symbol * symbol{scope.symbol()}) {
     innermostSymbol_ = symbol;
-  } else if (scope.IsDerivedType()) {
-    // PDT instantiations have no symbol.
-    return;
   }
-  for (const auto &set : scope.equivalenceSets()) {
-    CheckEquivalenceSet(set);
-  }
-  for (const auto &pair : scope) {
-    Check(*pair.second);
-  }
-  for (const Scope &child : scope.children()) {
-    Check(child);
-  }
-  if (scope.kind() == Scope::Kind::BlockData) {
-    CheckBlockData(scope);
+  if (scope.IsParameterizedDerivedTypeInstantiation()) {
+    auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
+    auto restorer2{context_.foldingContext().messages().SetContext(
+        scope.instantiationContext().get())};
+    for (const auto &pair : scope) {
+      CheckPointerInitialization(*pair.second);
+    }
+  } else {
+    auto restorer{common::ScopedSet(
+        scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
+    for (const auto &set : scope.equivalenceSets()) {
+      CheckEquivalenceSet(set);
+    }
+    for (const auto &pair : scope) {
+      Check(*pair.second);
+    }
+    for (const Scope &child : scope.children()) {
+      Check(child);
+    }
+    if (scope.kind() == Scope::Kind::BlockData) {
+      CheckBlockData(scope);
+    }
+    CheckGenericOps(scope);
   }
-  CheckGenericOps(scope);
 }
 
 void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {

 void CheckDeclarations(SemanticsContext &context) {
   CheckHelper{context}.Check();
 }
-
-void CheckInstantiatedDerivedType(
-    SemanticsContext &context, const DerivedTypeSpec &type) {
-  if (const Scope * scope{type.scope()}) {
-    CheckHelper checker{context};
-    for (const auto &pair : *scope) {
-      checker.CheckInitialization(*pair.second);
-    }
-  }
-}
-
 } // namespace Fortran::semantics

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

   }
 
   template <typename T> void CheckForImpureCall(const T &x) {
-    const auto &intrinsics{context_.foldingContext().intrinsics()};
-    if (auto bad{FindImpureCall(intrinsics, x)}) {
+    if (auto bad{FindImpureCall(context_.foldingContext(), x)}) {
       context_.Say(
           "Impure procedure '%s' may not be referenced in a %s"_err_en_US, *bad,
           LoopKindName());

flang/lib/Semantics/data-to-inits.cpp

       if (IsPointer(symbol)) {
         mutableObject.set_init(
             initialization.image.AsConstantDataPointer(*symbolType));
-        mutableObject.set_initWasValidated();
       } else {
         if (auto extents{evaluate::GetConstantExtents(context, symbol)}) {
           mutableObject.set_init(
               initialization.image.AsConstant(context, *symbolType, *extents));
-          mutableObject.set_initWasValidated();
         } else {
           exprAnalyzer.Say(symbol.name(),
               "internal: unknown shape for '%s' while constructing initializer from DATA"_err_en_US,

flang/lib/Semantics/expression.cpp

                         GetRank(*valueShape), symbol->name()),
                     *symbol);
               } else if (CheckConformance(messages, *componentShape,
-                             *valueShape, "component", "value")) {
+                             *valueShape, "component", "value", false,
+                             true /* can expand scalar value */)) {
                 if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
                     !IsExpandableScalar(*converted)) {
                   AttachDeclaration(

     }
     if (std::optional<characteristics::Procedure> procedure{
             characteristics::Procedure::Characterize(
-                ProcedureDesignator{specific}, context_.intrinsics())}) {
+                ProcedureDesignator{specific}, context_.foldingContext())}) {
       ActualArguments localActuals{actuals};
       if (specific.has<semantics::ProcBindingDetails>()) {
         if (!adjustActuals.value()(specific, localActuals)) {

 std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
     parser::CharBlock callSite, const ProcedureDesignator &proc,
     ActualArguments &arguments) {
-  auto chars{
-      characteristics::Procedure::Characterize(proc, context_.intrinsics())};
+  auto chars{characteristics::Procedure::Characterize(
+      proc, context_.foldingContext())};
   if (chars) {
     bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
     if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {

       auto rhShape{GetShape(foldingContext, *rhs)};
       if (lhShape && rhShape) {
         return evaluate::CheckConformance(foldingContext.messages(), *lhShape,
-            *rhShape, "left operand", "right operand");
+            *rhShape, "left operand", "right operand", true,
+            true /* scalar expansion is allowed */);
       }
     }
   }

flang/lib/Semantics/pointer-assignment.cpp

   PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs)
       : context_{context}, source_{lhs.name()},
         description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs},
-        procedure_{Procedure::Characterize(lhs, context.intrinsics())} {
+        procedure_{Procedure::Characterize(lhs, context)} {
     set_lhsType(TypeAndShape::Characterize(lhs, context));
     set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
     set_isVolatile(lhs.attrs().test(Attr::VOLATILE));

   } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
     funcName = intrinsic->name;
   }
-  auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
+  auto proc{Procedure::Characterize(f.proc(), context_)};
   if (!proc) {
     return false;
   }

 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
-  if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
+  if (auto chars{Procedure::Characterize(d, context_)}) {
     return Check(d.GetName(), false, &*chars);
   } else {
     return Check(d.GetName(), false);

 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
   const Procedure *procedure{nullptr};
-  auto chars{Procedure::Characterize(ref, context_.intrinsics())};
+  auto chars{Procedure::Characterize(ref, context_)};
   if (chars) {
     procedure = &*chars;
     if (chars->functionResult) {

 template <typename... A>
 parser::Message *PointerAssignmentChecker::Say(A &&...x) {
   auto *msg{context_.messages().Say(std::forward<A>(x)...)};
-  if (lhs_) {
-    return evaluate::AttachDeclaration(msg, *lhs_);
-  } else if (!source_.empty()) {
-    msg->Attach(source_, "Declaration of %s"_en_US, description_);
+  if (msg) {
+    if (lhs_) {
+      return evaluate::AttachDeclaration(msg, *lhs_);
+    }
+    if (!source_.empty()) {
+      msg->Attach(source_, "Declaration of %s"_en_US, description_);
+    }
   }
   return msg;
 }

     }
   }
   if (isBoundsRemapping && rhs.Rank() != 1 &&
-      !evaluate::IsSimplyContiguous(rhs, context.intrinsics())) {
+      !evaluate::IsSimplyContiguous(rhs, context)) {
     messages.Say("Pointer bounds remapping target must have rank 1 or be"
                  " simply contiguous"_err_en_US); // 10.2.2.3(9)
   }

flang/lib/Semantics/resolve-names.cpp

   }
 
   template <typename T>
-  MaybeExpr EvaluateConvertedExpr(
+  MaybeExpr EvaluateNonPointerInitializer(
       const Symbol &symbol, const T &expr, parser::CharBlock source) {
-    if (context().HasError(symbol)) {
-      return std::nullopt;
-    }
-    if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
-      if (auto converted{
-              evaluate::ConvertToType(symbol, std::move(*maybeExpr))}) {
-        return FoldExpr(std::move(*converted));
-      }
-      if (auto exprType{maybeExpr->GetType()}) {
-        Say(source,
-            "Initialization expression could not be converted to declared type of '%s' from %s"_err_en_US,
-            symbol.name(), exprType->AsFortran());
-      } else {
-        Say(source,
-            "Initialization expression could not be converted to declared type of '%s'"_err_en_US,
-            symbol.name());
+    if (!context().HasError(symbol)) {
+      if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
+        auto restorer{GetFoldingContext().messages().SetLocation(source)};
+        return evaluate::NonPointerInitializationExpr(
+            symbol, std::move(*maybeExpr), GetFoldingContext());
       }
     }
     return std::nullopt;

   void PointerInitialization(
       const parser::Name &, const parser::ProcPointerInit &);
   void NonPointerInitialization(
-      const parser::Name &, const parser::ConstantExpr &, bool inComponentDecl);
+      const parser::Name &, const parser::ConstantExpr &);
   void CheckExplicitInterface(const parser::Name &);
   void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
 

   bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
   bool IsUplevelReference(const Symbol &);
   const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
-  bool CheckInitialDataTarget(const Symbol &, const SomeExpr &, SourceName);
-  void CheckInitialProcTarget(const Symbol &, const parser::Name &, SourceName);
   void Initialization(const parser::Name &, const parser::Initialization &,
       bool inComponentDecl);
   bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);

   const auto &expr{std::get<parser::ConstantExpr>(x.t)};
   ApplyImplicitRules(symbol);
   Walk(expr);
-  if (auto converted{
-          EvaluateConvertedExpr(symbol, expr, expr.thing.value().source)}) {
+  if (auto converted{EvaluateNonPointerInitializer(
+          symbol, expr, expr.thing.value().source)}) {
     symbol.get<ObjectEntityDetails>().set_init(std::move(*converted));
   }
   return false;

       SetType(name, *type);
       if (auto &init{
               std::get<std::optional<parser::ScalarIntConstantExpr>>(decl.t)}) {
-        if (auto maybeExpr{EvaluateConvertedExpr(
+        if (auto maybeExpr{EvaluateNonPointerInitializer(
                 *symbol, *init, init->thing.thing.thing.value().source)}) {
-          auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)};
-          CHECK(intExpr);
-          symbol->get<TypeParamDetails>().set_init(std::move(*intExpr));
+          if (auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)}) {
+            symbol->get<TypeParamDetails>().set_init(std::move(*intExpr));
+          }
         }
       }
     }

   return nullptr;
 }
 
-// C764, C765
-bool DeclarationVisitor::CheckInitialDataTarget(
-    const Symbol &pointer, const SomeExpr &expr, SourceName source) {
-  auto &context{GetFoldingContext()};
-  auto restorer{context.messages().SetLocation(source)};
-  auto dyType{evaluate::DynamicType::From(pointer)};
-  CHECK(dyType);
-  auto designator{evaluate::TypedWrapper<evaluate::Designator>(
-      *dyType, evaluate::DataRef{pointer})};
-  CHECK(designator);
-  return CheckInitialTarget(context, *designator, expr);
-}
-
-void DeclarationVisitor::CheckInitialProcTarget(
-    const Symbol &pointer, const parser::Name &target, SourceName source) {
-  // C1519 - must be nonelemental external or module procedure,
-  // or an unrestricted specific intrinsic function.
-  if (const Symbol * targetSym{target.symbol}) {
-    const Symbol &ultimate{targetSym->GetUltimate()};
-    if (ultimate.attrs().test(Attr::INTRINSIC)) {
-    } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
-        ultimate.owner().kind() != Scope::Kind::Module) {
-      Say(source,
-          "Procedure pointer '%s' initializer '%s' is neither "
-          "an external nor a module procedure"_err_en_US,
-          pointer.name(), ultimate.name());
-    } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
-      Say(source,
-          "Procedure pointer '%s' cannot be initialized with the "
-          "elemental procedure '%s"_err_en_US,
-          pointer.name(), ultimate.name());
-    } else {
-      // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
-    }
-  }
-}
-
 void DeclarationVisitor::Initialization(const parser::Name &name,
     const parser::Initialization &init, bool inComponentDecl) {
   // Traversal of the initializer was deferred to here so that the

   }
   Symbol &ultimate{name.symbol->GetUltimate()};
   if (IsAllocatable(ultimate)) {
-    Say(name, "Allocatable component '%s' cannot be initialized"_err_en_US);
-    return;
-  }
-  if (std::holds_alternative<parser::InitialDataTarget>(init.u)) {
-    // Defer analysis further to the end of the specification parts so that
-    // forward references and attribute checks (e.g., SAVE) work better.
-    // TODO: But pointer initializers of components in named constants of
-    // derived types may still need more attention.
+    Say(name, "Allocatable object '%s' cannot be initialized"_err_en_US);
     return;
   }
   if (auto *object{ultimate.detailsIf<ObjectEntityDetails>()}) {

     std::visit(
         common::visitors{
             [&](const parser::ConstantExpr &expr) {
-              NonPointerInitialization(name, expr, inComponentDecl);
+              NonPointerInitialization(name, expr);
             },
             [&](const parser::NullInit &null) {
               Walk(null);

               }
             },
             [&](const parser::InitialDataTarget &) {
-              DIE("InitialDataTarget can't appear here");
+              // Defer analysis to the end of the specification part
+              // so that forward references and attribute checks like SAVE
+              // work better.
             },
             [&](const std::list<Indirection<parser::DataStmtValue>> &) {
               // TODO: Need to Walk(init.u); when implementing this case

           CHECK(!details->init());
           Walk(target);
           if (MaybeExpr expr{EvaluateExpr(target)}) {
-            CheckInitialDataTarget(ultimate, *expr, target.value().source);
+            // Validation is done in declaration checking.
             details->set_init(std::move(*expr));
           }
         }

         CHECK(!details.init());
         Walk(target);
         if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) {
-          CheckInitialProcTarget(ultimate, *targetName, name.source);
           if (targetName->symbol) {
+            // Validation is done in declaration checking.
             details.set_init(*targetName->symbol);
           }
         } else {

   }
 }
 
-void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
-    const parser::ConstantExpr &expr, bool inComponentDecl) {
+void DeclarationVisitor::NonPointerInitialization(
+    const parser::Name &name, const parser::ConstantExpr &expr) {
   if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
     if (!context().HasError(ultimate)) {

       } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
         CHECK(!details->init());
         Walk(expr);
-        if (inComponentDecl) {
-          // TODO: check C762 - all bounds and type parameters of component
-          // are colons or constant expressions if component is initialized
+        if (ultimate.owner().IsParameterizedDerivedType()) {
           // Can't convert to type of component, which might not yet
-          // be known; that's done later during instantiation.
+          // be known; that's done later during PDT instantiation.
           if (MaybeExpr value{EvaluateExpr(expr)}) {
             details->set_init(std::move(*value));
           }
-        } else if (MaybeExpr folded{EvaluateConvertedExpr(
+        } else if (MaybeExpr folded{EvaluateNonPointerInitializer(
                        ultimate, expr, expr.thing.value().source)}) {
           details->set_init(std::move(*folded));
         }

     return; // error occurred creating scope
   }
   SetScope(*node.scope());
-  // The initializers of pointers, pointer components, and non-deferred
-  // type-bound procedure bindings have not yet been traversed.
+  // The initializers of pointers, the default initializers of pointer
+  // components, and non-deferred type-bound procedure bindings have not
+  // yet been traversed.
   // We do that now, when any (formerly) forward references that appear
-  // in those initializers will resolve to the right symbols.
+  // in those initializers will resolve to the right symbols without
+  // incurring spurious errors with IMPLICIT NONE.
   DeferredCheckVisitor{*this}.Walk(node.spec());
   DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK
   for (Scope &childScope : currScope().children()) {
-    if (childScope.IsDerivedType() && !childScope.symbol()) {
+    if (childScope.IsParameterizedDerivedTypeInstantiation()) {
       FinishDerivedTypeInstantiation(childScope);
     }
   }

   }
 }
 
-// Fold object pointer initializer designators with the actual
-// type parameter values of a particular instantiation.
+// Duplicate and fold component object pointer default initializer designators
+// using the actual type parameter values of each particular instantiation.
+// Validation is done later in declaration checking.
 void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) {
   CHECK(scope.IsDerivedType() && !scope.symbol());
   if (DerivedTypeSpec * spec{scope.derivedTypeSpec()}) {

flang/lib/Semantics/tools.cpp

   }
 }
 
-bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
+bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements,
+    const Symbol *derivedTypeSymbol) {
   if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
     return true;
   } else if (IsNamedConstant(symbol)) {

       return true;
     } else if (!IsPointer(symbol) && object->type()) {
       if (const auto *derived{object->type()->AsDerived()}) {
-        if (derived->HasDefaultInitialization()) {
+        if (&derived->typeSymbol() == derivedTypeSymbol) {
+          // error recovery: avoid infinite recursion on invalid
+          // recursive usage of a derived type
+        } else if (derived->HasDefaultInitialization()) {
           return true;
         }
       }

flang/lib/Semantics/type.cpp

     if (!FindParameter(name)) {
       const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
       if (details.init()) {
-        auto expr{
-            evaluate::Fold(foldingContext, common::Clone(details.init()))};
-        AddParamValue(name, ParamValue{std::move(*expr), details.attr()});
+        auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})};
+        AddParamValue(name,
+            ParamValue{
+                std::move(std::get<SomeIntExpr>(expr.u)), details.attr()});
       } else if (!context.HasError(symbol)) {
         messages.Say(name_,
             "Type parameter '%s' lacks a value and has no default"_err_en_US,

 
 bool DerivedTypeSpec::HasDefaultInitialization() const {
   DirectComponentIterator components{*this};
-  return bool{std::find_if(components.begin(), components.end(),
-      [](const Symbol &component) { return IsInitialized(component); })};
+  return bool{std::find_if(
+      components.begin(), components.end(), [&](const Symbol &component) {
+        return IsInitialized(component, false, &typeSymbol());
+      })};
 }
 
 ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {

           }
         }
       }
+      if (!IsPointer(symbol)) {
+        if (auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+          if (MaybeExpr & init{object->init()}) {
+            auto restorer{foldingContext.messages().SetLocation(symbol.name())};
+            init = evaluate::NonPointerInitializationExpr(
+                symbol, std::move(*init), foldingContext);
+          }
+        }
+      }
     }
     return;
   }
   Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
   newScope.set_derivedTypeSpec(*this);
   ReplaceScope(newScope);
+  auto restorer{foldingContext.WithPDTInstance(*this)};
+  std::string desc{typeSymbol_.name().ToString()};
+  char sep{'('};
   for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
     const SourceName &name{symbol.name()};
     if (typeScope.find(symbol.name()) != typeScope.end()) {

         const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
         paramValue->set_attr(details.attr());
         if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
-          // Ensure that any kind type parameters with values are
-          // constant by now.
-          if (details.attr() == common::TypeParamAttr::Kind) {
-            // Any errors in rank and type will have already elicited
-            // messages, so don't pile on by complaining further here.
-            if (auto maybeDynamicType{expr->GetType()}) {
-              if (expr->Rank() == 0 &&
-                  maybeDynamicType->category() == TypeCategory::Integer) {
-                if (!evaluate::ToInt64(*expr)) {
-                  if (auto *msg{foldingContext.messages().Say(
-                          "Value of kind type parameter '%s' (%s) is not "
-                          "a scalar INTEGER constant"_err_en_US,
-                          name, expr->AsFortran())}) {
-                    msg->Attach(name, "declared here"_en_US);
-                  }
-                }
-              }
+          if (auto folded{evaluate::NonPointerInitializationExpr(symbol,
+                  SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) {
+            desc += sep;
+            desc += name.ToString();
+            desc += '=';
+            desc += folded->AsFortran();
+            sep = ',';
+            TypeParamDetails instanceDetails{details.attr()};
+            if (const DeclTypeSpec * type{details.type()}) {
+              instanceDetails.set_type(*type);
             }
+            instanceDetails.set_init(
+                std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*folded))));
+            newScope.try_emplace(name, std::move(instanceDetails));
           }
-          TypeParamDetails instanceDetails{details.attr()};
-          if (const DeclTypeSpec * type{details.type()}) {
-            instanceDetails.set_type(*type);
-          }
-          instanceDetails.set_init(std::move(*expr));
-          newScope.try_emplace(name, std::move(instanceDetails));
         }
       }
     }
   }
+  parser::Message *contextMessage{nullptr};
+  if (sep != '(') {
+    desc += ')';
+    contextMessage = new parser::Message{foldingContext.messages().at(),
+        "instantiation of parameterized derived type '%s'"_en_US, desc};
+    if (auto outer{containingScope.instantiationContext()}) {
+      contextMessage->SetContext(outer.get());
+    }
+    newScope.set_instantiationContext(contextMessage);
+  }
   // Instantiate every non-parameter symbol from the original derived
   // type's scope into the new instance.
-  auto restorer{foldingContext.WithPDTInstance(*this)};
   newScope.AddSourceRange(typeScope.sourceRange());
+  auto restorer2{foldingContext.messages().SetContext(contextMessage)};
   InstantiateHelper{context, newScope}.InstantiateComponents(typeScope);
-  CheckInstantiatedDerivedType(context, *this);
 }
 
 void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {

     if (const DeclTypeSpec * newType{InstantiateType(newSymbol)}) {
       details->ReplaceType(*newType);
     }
-    details->set_init(Fold(std::move(details->init())));
     for (ShapeSpec &dim : details->shape()) {
       if (dim.lbound().isExplicit()) {
         dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));

         dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));
       }
     }
+    if (MaybeExpr & init{details->init()}) {
+      // Non-pointer components with default initializers are
+      // processed now so that those default initializers can be used
+      // in PARAMETER structure constructors.
+      auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
+      init = IsPointer(newSymbol)
+          ? evaluate::Fold(foldingContext(), std::move(*init))
+          : evaluate::NonPointerInitializationExpr(
+                newSymbol, std::move(*init), foldingContext());
+    }
   }
 }
 

flang/test/Semantics/array-constr-values.f90

   !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name
   real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)]
 
+  !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value
   !ERROR: The stride of an implied DO loop must not be zero
   integer, parameter :: bad2(*) = [(j, j=1,1,0)]
 end subroutine checkC7115

flang/test/Semantics/data04.f90

       end type
       type(large) largeNumber
       type(large), allocatable :: allocatableLarge
-      !ERROR: An automatic variable must not be initialized
+      !ERROR: An automatic variable or component must not be initialized
       type(large) :: largeNumberArray(i)
       type(large) :: largeArray(5)
       character :: name(i)

flang/test/Semantics/init01.f90

 subroutine dataobjects(j)
   integer, intent(in) :: j
   real, parameter :: x1(*) = [1., 2.]
-!ERROR: Implied-shape array 'x2' has rank 2, but its initializer has rank 1
+!ERROR: Implied-shape parameter 'x2' has rank 2 but its initializer has rank 1
   real, parameter :: x2(*,*) = [1., 2.]
-!ERROR: Shape of 'x3' is not implied, deferred, nor constant
+!ERROR: Named constant 'x3' array must have constant shape
   real, parameter :: x3(j) = [1., 2.]
-!ERROR: An automatic variable must not be initialized
+!ERROR: Shape of initialized object 'x4' must be constant
   real :: x4(j) = [1., 2.]
-!ERROR: 'x5' has rank 2, but its initializer has rank 1
+!ERROR: Rank of initialized object is 2, but initialization expression has rank 1
   real :: x5(2,2) = [1., 2., 3., 4.]
   real :: x6(2,2) = 5.
-!ERROR: 'x7' has rank 0, but its initializer has rank 1
+!ERROR: Rank of initialized object is 0, but initialization expression has rank 1
   real :: x7 = [1.]
   real :: x8(2,2) = reshape([1., 2., 3., 4.], [2, 2])
-!ERROR: Dimension 1 of object has extent 3, but initializer has extent 2
+!ERROR: Dimension 1 of initialized object has extent 3, but initialization expression has extent 2
   real :: x9(3) = [1., 2.]
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
   real :: x10(2,3) = reshape([real::(k,k=1,6)], [3, 2])
 end subroutine
 

   real, save :: a3
   real, target, save :: a4
   type :: t1
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x1(2) = [1., 2., 3.]
   end type
   type :: t2(kind, len)
     integer, kind :: kind
     integer, len :: len
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x1(2) = [1., 2., 3.]
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x2(kind) = [1., 2., 3.]
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
+!ERROR: An automatic variable or component must not be initialized
     real :: x3(len) = [1., 2., 3.]
     real, pointer :: p1(:) => a1
 !ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
+!ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
     real, pointer :: p2 => a2
 !ERROR: An initial data target may not be a reference to an object 'a3' that lacks the TARGET attribute
+!ERROR: An initial data target may not be a reference to an object 'a3' that lacks the TARGET attribute
     real, pointer :: p3 => a3
 !ERROR: Pointer has rank 0 but target has rank 1
+!ERROR: Pointer has rank 0 but target has rank 1
     real, pointer :: p4 => a1
 !ERROR: Pointer has rank 1 but target has rank 0
+!ERROR: Pointer has rank 1 but target has rank 0
     real, pointer :: p5(:) => a4
   end type
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
   type(t2(3,3)) :: o1
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
   type(t2(2,2)) :: o2
 end subroutine

flang/test/Semantics/resolve37.f90

 real :: u(l*2)
 !ERROR: Must have INTEGER type, but is REAL(4)
 character(len=l) :: v
-!ERROR: Initialization expression for PARAMETER 'o' (o) cannot be computed as a constant value
+!ERROR: Value of named constant 'o' (o) cannot be computed as a constant value
 real, parameter ::  o = o
 !ERROR: Must be a constant value
 integer, parameter ::  p = 0/0

flang/test/Semantics/resolve44.f90

     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

flang/test/Semantics/resolve58.f90

   real :: b(*,*)  ! C836
   !ERROR: Implied-shape array 'c' must be a named constant
   real :: c(*)  ! C836
-  !ERROR: Named constant 'd' array must have explicit or implied shape
+  !ERROR: Named constant 'd' array must have constant or implied shape
   integer, parameter :: d(:) = [1, 2, 3]
 end
 

flang/test/Semantics/resolve69.f90

   end type derived
 
   type (derived(constVal, 3)) :: constDerivedKind
-!ERROR: Value of kind type parameter 'typekind' (nonconstval) is not a scalar INTEGER constant
+!ERROR: Value of kind type parameter 'typekind' (nonconstval) must be a scalar INTEGER constant
 !ERROR: Invalid specification expression: reference to local entity 'nonconstval'
   type (derived(nonConstVal, 3)) :: nonConstDerivedKind
 

flang/test/Semantics/structconst02.f90

     integer(kind=ik) :: ix = 0
     real(kind=rk) :: rx = 0.
     complex(kind=zk) :: zx = (0.,0.)
+    !ERROR: An automatic variable or component must not be initialized
     character(kind=ck,len=len) :: cx = ' '
     logical(kind=lk) :: lx = .false.
     real(kind=rk), pointer :: rp => NULL()

flang/tools/f18/f18.cpp

 
 // Temporary Fortran front end driver main program for development scaffolding.
 
+#include "f18_version.h"
 #include "flang/Common/Fortran-features.h"
 #include "flang/Common/default-kinds.h"
 #include "flang/Evaluate/expression.h"

 #include "llvm/Support/Errno.h"
 #include "llvm/Support/FileSystem.h"
 #include "llvm/Support/Program.h"
+#include "llvm/Support/Signals.h"
 #include "llvm/Support/raw_ostream.h"
 #include <cstdio>
 #include <cstring>

 #include <string>
 #include <vector>
 
-#include "f18_version.h"
-
 static std::list<std::string> argList(int argc, char *const argv[]) {
   std::list<std::string> result;
   for (int j = 0; j < argc; ++j) {

       return exitStatus;
     } else if (arg == "-V" || arg == "--version") {
       return printVersion();
+    } else if (arg == "-fdebug-stack-trace") {
+      llvm::sys::PrintStackTraceOnErrorSignal(llvm::StringRef{}, true);
     } else {
       driver.F18_FCArgs.push_back(arg);
       if (arg == "-v") {