[flang] DATA stmt processing (part 3/4): Remaining prep work

[klausler]

Summary

Rolls up small changes across the frontend to prepare for the large
forthcoming patch (part 4/4) that completes DATA statement processing
via conversion to initializers.

[PeteSteinfeld]

Everything builds, tests, and looks good.

flang/documentation/FortranForCProgrammers.md

 There are five built-in ("intrinsic") types: `INTEGER`, `REAL`, `COMPLEX`,
 `LOGICAL`, and `CHARACTER`.
 They are parameterized with "kind" values, which should be treated as
 non-portable integer codes, although in practice today these are the
 byte sizes of the data.
 (For `COMPLEX`, the kind type parameter value is the byte size of one of the
 two `REAL` components, or half of the total size.)
 The legacy `DOUBLE PRECISION` intrinsic type is an alias for a kind of `REAL`
-that should be bigger than the default `REAL`.
+that should be more precise, and bigger, than the default `REAL`.
 
 `COMPLEX` is a simple structure that comprises two `REAL` components.
 
 `CHARACTER` data also have length, which may or may not be known at compilation
 time.
 `CHARACTER` variables are fixed-length strings and they get padded out
 with space characters when not completely assigned.
 

 disassociated pointer, use an `IF` statement, not a logical `.AND.`
 operation.
 In fact, Fortran can remove function calls from expressions if their
 values are not required to determine the value of the expression's
 result; e.g., if there is a `PRINT` statement in function `F`, it
 may or may not be executed by the assignment statement `X=0*F()`.
 (Well, it probably will be, in practice, but compilers always reserve
 the right to optimize better.)
+
+Unless they have an explicit suffix (`1.0_8`, `2.0_8`) or a `D`
+exponent (`3.0D0`), real literal constants in Fortran have the
+default `REAL` type -- *not* `double` as in the case in C and C++.
+If you're not careful, you can lose precision at compilation time
+from your constant values and never know it.

flang/include/flang/Common/interval.h

public:
   constexpr Interval(const A &s, std::size_t n = 1) : start_{s}, size_{n} {}
   constexpr Interval(A &&s, std::size_t n = 1)
       : start_{std::move(s)}, size_{n} {}
   constexpr Interval(const Interval &) = default;
   constexpr Interval(Interval &&) = default;
   constexpr Interval &operator=(const Interval &) = default;
   constexpr Interval &operator=(Interval &&) = default;
 
+  constexpr bool operator<(const Interval &that) const {
+    return start_ < that.start_ ||
+        (start_ == that.start_ && size_ < that.size_);
+  }
+  constexpr bool operator<=(const Interval &that) const {
+    return start_ < that.start_ ||
+        (start_ == that.start_ && size_ <= that.size_);
+  }
   constexpr bool operator==(const Interval &that) const {
     return start_ == that.start_ && size_ == that.size_;
   }
   constexpr bool operator!=(const Interval &that) const {
     return !(*this == that);
   }
+  constexpr bool operator>=(const Interval &that) const {
+    return !(*this < that);
+  }
+  constexpr bool operator>(const Interval &that) const {
+    return !(*this <= that);
+  }
 
   constexpr const A &start() const { return start_; }
   constexpr std::size_t size() const { return size_; }
   constexpr bool empty() const { return size_ == 0; }
 
   constexpr bool Contains(const A &x) const {
     return start_ <= x && x < start_ + size_;
   }

flang/include/flang/Evaluate/characteristics.h

struct Procedure {
   static std::optional<Procedure> Characterize(
       const semantics::Symbol &, const IntrinsicProcTable &);
   static std::optional<Procedure> Characterize(
       const ProcedureDesignator &, const IntrinsicProcTable &);
   static std::optional<Procedure> Characterize(
       const ProcedureRef &, const IntrinsicProcTable &);
 
   // At most one of these will return true.
-  // For "EXTERNAL P" with no calls to P, both will be false.
+  // For "EXTERNAL P" with no type for or calls to P, both will be false.
   bool IsFunction() const { return functionResult.has_value(); }
   bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
 
   bool IsPure() const { return attrs.test(Attr::Pure); }
   bool IsElemental() const { return attrs.test(Attr::Elemental); }
   bool IsBindC() const { return attrs.test(Attr::BindC); }
   bool HasExplicitInterface() const {
     return !attrs.test(Attr::ImplicitInterface);

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

 
 // Predicate: true when an expression is a constant expression (in the
 // strict sense of the Fortran standard); it may not (yet) be a hard
 // constant value.
 template <typename A> bool IsConstantExpr(const A &);
 extern template bool IsConstantExpr(const Expr<SomeType> &);
 extern template bool IsConstantExpr(const Expr<SomeInteger> &);
 extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
+extern template bool IsConstantExpr(const StructureConstructor &);
 
 // 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
+// will be generated if and only if the result of the function is false.
 bool IsInitialDataTarget(
     const Expr<SomeType> &, parser::ContextualMessages * = nullptr);
 
+bool IsInitialProcedureTarget(const Symbol &);
+bool IsInitialProcedureTarget(const ProcedureDesignator &);
+bool IsInitialProcedureTarget(const Expr<SomeType> &);
+
 // 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,

flang/include/flang/Evaluate/constant.h

 namespace Fortran::evaluate {
 
 using semantics::Symbol;
 using SymbolRef = common::Reference<const Symbol>;
 
 // Wraps a constant value in a class templated by its resolved type.
 // This Constant<> template class should be instantiated only for
 // concrete intrinsic types and SomeDerived.  There is no instance
-// Constant<Expr<SomeType>> since there is no way to constrain each
+// Constant<SomeType> since there is no way to constrain each
 // element of its array to hold the same type.  To represent a generic
-// constants, use a generic expression like Expr<SomeInteger> &
+// constant, use a generic expression like Expr<SomeInteger> or
 // Expr<SomeType>) to wrap the appropriate instantiation of Constant<>.
 
 template <typename> class Constant;
 
 // When describing shapes of constants or specifying 1-based subscript
 // values as indices into constants, use a vector of integers.
 using ConstantSubscripts = std::vector<ConstantSubscript>;
 inline int GetRank(const ConstantSubscripts &s) {
   return static_cast<int>(s.size());
 }
 
 std::size_t TotalElementCount(const ConstantSubscripts &);
 
 // Validate dimension re-ordering like ORDER in RESHAPE.
 // On success, return a vector that can be used as dimOrder in
-// ConstantBound::IncrementSubscripts.
+// ConstantBound::IncrementSubscripts().
 std::optional<std::vector<int>> ValidateDimensionOrder(
     int rank, const std::vector<int> &order);
 
 bool IsValidShape(const ConstantSubscripts &);
 
 class ConstantBounds {
 public:
   ConstantBounds() = default;
   explicit ConstantBounds(const ConstantSubscripts &shape);
   explicit ConstantBounds(ConstantSubscripts &&shape);
   ~ConstantBounds();
   const ConstantSubscripts &shape() const { return shape_; }
   const ConstantSubscripts &lbounds() const { return lbounds_; }
   void set_lbounds(ConstantSubscripts &&);
   int Rank() const { return GetRank(shape_); }
   Constant<SubscriptInteger> SHAPE() const;
 
   // If no optional dimension order argument is passed, increments a vector of
   // subscripts in Fortran array order (first dimension varying most quickly).
   // Otherwise, increments the vector of subscripts according to the given
-  // dimension order (dimension dimOrder[0] varying most quickly. Dimensions
-  // indexing is zero based here.) Returns false when last element was visited.
+  // dimension order (dimension dimOrder[0] varying most quickly; dimension
+  // indexing is zero based here). Returns false when last element was visited.
   bool IncrementSubscripts(
       ConstantSubscripts &, const std::vector<int> *dimOrder = nullptr) const;
 
 protected:
   ConstantSubscript SubscriptsToOffset(const ConstantSubscripts &) const;
 
 private:
   ConstantSubscripts shape_;

 class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
 public:
   using Result = Type<TypeCategory::Character, KIND>;
   using Element = Scalar<Result>;
 
   CLASS_BOILERPLATE(Constant)
   explicit Constant(const Scalar<Result> &);
   explicit Constant(Scalar<Result> &&);
-  Constant(ConstantSubscript, std::vector<Element> &&, ConstantSubscripts &&);
+  Constant(
+      ConstantSubscript length, std::vector<Element> &&, ConstantSubscripts &&);
   ~Constant();
 
   bool operator==(const Constant &that) const {
     return shape() == that.shape() && values_ == that.values_;
   }
   bool empty() const;
   std::size_t size() const;
 
static constexpr DynamicType GetType() {
     return {TypeCategory::Character, KIND};
   }
   std::size_t CopyFrom(const Constant &source, std::size_t count,
       ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
 
 private:
   Scalar<Result> values_; // one contiguous string
   ConstantSubscript length_;
-  ConstantSubscripts shape_;
-  ConstantSubscripts lbounds_;
 };
 
 class StructureConstructor;
 using StructureConstructorValues =
     std::map<SymbolRef, common::CopyableIndirection<Expr<SomeType>>>;
 
 template <>
 class Constant<SomeDerived>

flang/include/flang/Evaluate/fold.h

 //===-- include/flang/Evaluate/fold.h ---------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_EVALUATE_FOLD_H_
 #define FORTRAN_EVALUATE_FOLD_H_
 
 // Implements expression tree rewriting, particularly constant expression
-// evaluation.
+// and designator reference evaluation.
 
 #include "common.h"
 #include "constant.h"
 #include "expression.h"
 #include "tools.h"
 #include "type.h"
 #include <variant>
 

flang/include/flang/Evaluate/tools.h

 bool IsProcedurePointer(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);
 
 // Follow use, host, and construct assocations to a variable, if any.
 const Symbol *GetAssociationRoot(const Symbol &);
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);
+int CountNonConstantLenParameters(const DerivedTypeSpec &);
 const Symbol &GetUsedModule(const UseDetails &);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/include/flang/Parser/parse-tree.h

 
 // Represents an analyzed expression
 using TypedExpr = std::unique_ptr<evaluate::GenericExprWrapper,
     common::Deleter<evaluate::GenericExprWrapper>>;
 
 // R845 data-stmt-constant ->
 //        scalar-constant | scalar-constant-subobject |
 //        signed-int-literal-constant | signed-real-literal-constant |
-//        null-init | initial-data-target | structure-constructor
+//        null-init | initial-data-target |
+//        constant-structure-constructor    <- added "constant-"
 struct DataStmtConstant {
   UNION_CLASS_BOILERPLATE(DataStmtConstant);
   CharBlock source;
   mutable TypedExpr typedExpr;
   std::variant<Scalar<ConstantValue>, Scalar<ConstantSubobject>,
       SignedIntLiteralConstant, SignedRealLiteralConstant,
       SignedComplexLiteralConstant, NullInit, InitialDataTarget,
-      StructureConstructor>
+      Constant<StructureConstructor>>
       u;
 };
 
 // R844 data-stmt-repeat -> scalar-int-constant | scalar-int-constant-subobject
 // R607 int-constant -> constant
 // R604 constant -> literal-constant | named-constant
 // (only literal-constant -> int-literal-constant applies)
 struct DataStmtRepeat {
   UNION_CLASS_BOILERPLATE(DataStmtRepeat);
   std::variant<IntLiteralConstant, Scalar<Integer<ConstantSubobject>>> u;
 };
 
 // R843 data-stmt-value -> [data-stmt-repeat *] data-stmt-constant
 struct DataStmtValue {
   TUPLE_CLASS_BOILERPLATE(DataStmtValue);
+  mutable std::size_t repetitions{1}; // replaced during semantics
   std::tuple<std::optional<DataStmtRepeat>, DataStmtConstant> t;
 };
 
 // R841 data-i-do-object ->
 //        array-element | scalar-structure-component | data-implied-do
 struct DataIDoObject {
   UNION_CLASS_BOILERPLATE(DataIDoObject);
   std::variant<Scalar<common::Indirection<Designator>>,

flang/include/flang/Parser/tools.h

 const Name &GetLastName(const Designator &);
 const Name &GetLastName(const ProcComponentRef &);
 const Name &GetLastName(const ProcedureDesignator &);
 const Name &GetLastName(const Call &);
 const Name &GetLastName(const FunctionReference &);
 const Name &GetLastName(const Variable &);
 const Name &GetLastName(const AllocateObject &);
 
+// GetFirstName() isolates and returns a reference to the leftmost Name
+// in a variable.
+const Name &GetFirstName(const Name &);
+const Name &GetFirstName(const StructureComponent &);
+const Name &GetFirstName(const DataRef &);
+const Name &GetFirstName(const Substring &);
+const Name &GetFirstName(const Designator &);
+const Name &GetFirstName(const ProcComponentRef &);
+const Name &GetFirstName(const ProcedureDesignator &);
+const Name &GetFirstName(const Call &);
+const Name &GetFirstName(const FunctionReference &);
+const Name &GetFirstName(const Variable &);
+
 // When a parse tree node is an instance of a specific type wrapped in
 // layers of packaging, return a pointer to that object.
 // Implemented with mutually recursive template functions that are
 // wrapped in a struct to avoid prototypes.
 struct UnwrapperHelper {
 
   template <typename A, typename B> static const A *Unwrap(B *p) {
     if (p) {

flang/include/flang/Semantics/expression.h

public:
   int GetDefaultKind(common::TypeCategory);
   DynamicType GetDefaultKindOfType(common::TypeCategory);
 
   // Return false and emit error if these checks fail:
   bool CheckIntrinsicKind(TypeCategory, std::int64_t kind);
   bool CheckIntrinsicSize(TypeCategory, std::int64_t size);
 
   // Manage a set of active implied DO loops.
-  bool AddImpliedDo(parser::CharBlock, int);
+  bool AddImpliedDo(parser::CharBlock, int kind);
   void RemoveImpliedDo(parser::CharBlock);
+
+  // When the argument is the name of an active implied DO index, returns
+  // its INTEGER kind type parameter.
   std::optional<int> IsImpliedDo(parser::CharBlock) const;
 
   Expr<SubscriptInteger> AnalyzeKindSelector(common::TypeCategory category,
       const std::optional<parser::KindSelector> &);
 
   MaybeExpr Analyze(const parser::Expr &);
   MaybeExpr Analyze(const parser::Variable &);
   MaybeExpr Analyze(const parser::Designator &);
-  MaybeExpr Analyze(const parser::DataStmtConstant &);
+  MaybeExpr Analyze(const parser::DataStmtValue &);
 
   template <typename A> MaybeExpr Analyze(const common::Indirection<A> &x) {
     return Analyze(x.value());
   }
   template <typename A> MaybeExpr Analyze(const std::optional<A> &x) {
     if (x) {
       return Analyze(*x);
     } else {
private:
   MaybeExpr Analyze(const parser::ComplexPart &);
   MaybeExpr Analyze(const parser::ComplexLiteralConstant &);
   MaybeExpr Analyze(const parser::LogicalLiteralConstant &);
   MaybeExpr Analyze(const parser::CharLiteralConstant &);
   MaybeExpr Analyze(const parser::HollerithLiteralConstant &);
   MaybeExpr Analyze(const parser::BOZLiteralConstant &);
   MaybeExpr Analyze(const parser::NamedConstant &);
   MaybeExpr Analyze(const parser::NullInit &);
+  MaybeExpr Analyze(const parser::DataStmtConstant &);
   MaybeExpr Analyze(const parser::Substring &);
   MaybeExpr Analyze(const parser::ArrayElement &);
   MaybeExpr Analyze(const parser::CoindexedNamedObject &);
   MaybeExpr Analyze(const parser::CharLiteralConstantSubstring &);
   MaybeExpr Analyze(const parser::ArrayConstructor &);
   MaybeExpr Analyze(const parser::FunctionReference &,
       std::optional<parser::StructureConstructor> * = nullptr);
   MaybeExpr Analyze(const parser::Expr::Parentheses &);

 public:
   explicit ExprChecker(SemanticsContext &);
 
   template <typename A> bool Pre(const A &) { return true; }
   template <typename A> void Post(const A &) {}
   bool Walk(const parser::Program &);
 
   bool Pre(const parser::Expr &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
   bool Pre(const parser::Variable &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
-  bool Pre(const parser::DataStmtConstant &x) {
-    AnalyzeExpr(context_, x);
+  bool Pre(const parser::DataStmtValue &x) {
+    exprAnalyzer_.Analyze(x);
     return false;
   }
+  bool Pre(const parser::DataImpliedDo &);
+
   bool Pre(const parser::CallStmt &x) {
     AnalyzeCallStmt(context_, x);
     return false;
   }
   bool Pre(const parser::AssignmentStmt &x) {
     AnalyzeAssignmentStmt(context_, x);
     return false;
   }
   bool Pre(const parser::PointerAssignmentStmt &x) {
     AnalyzePointerAssignmentStmt(context_, x);
     return false;
   }
 
   template <typename A> bool Pre(const parser::Scalar<A> &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
   template <typename A> bool Pre(const parser::Constant<A> &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
   template <typename A> bool Pre(const parser::Integer<A> &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
   template <typename A> bool Pre(const parser::Logical<A> &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
   template <typename A> bool Pre(const parser::DefaultChar<A> &x) {
-    AnalyzeExpr(context_, x);
+    exprAnalyzer_.Analyze(x);
     return false;
   }
 
 private:
   SemanticsContext &context_;
+  evaluate::ExpressionAnalyzer exprAnalyzer_{context_};
 };
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_EXPRESSION_H_

flang/include/flang/Semantics/scope.h

public:
   std::optional<parser::MessageFixedText> SetImportKind(ImportKind);
 
   void add_importName(const SourceName &);
 
   const DerivedTypeSpec *derivedTypeSpec() const { return derivedTypeSpec_; }
   DerivedTypeSpec *derivedTypeSpec() { return derivedTypeSpec_; }
   void set_derivedTypeSpec(DerivedTypeSpec &spec) { derivedTypeSpec_ = &spec; }
 
+  bool hasSAVE() const { return hasSAVE_; }
+  void set_hasSAVE(bool yes = true) { hasSAVE_ = yes; }
+
   // The range of the source of this and nested scopes.
   const parser::CharBlock &sourceRange() const { return sourceRange_; }
   void AddSourceRange(const parser::CharBlock &);
   // Find the smallest scope under this one that contains source
   const Scope *FindScope(parser::CharBlock) const;
   Scope *FindScope(parser::CharBlock);
 
   // Attempts to find a match for a derived type instance
private:
   std::list<EquivalenceSet> equivalenceSets_;
   mapType crayPointers_;
   std::map<SourceName, common::Reference<Scope>> submodules_;
   std::list<DeclTypeSpec> declTypeSpecs_;
   std::string chars_;
   std::optional<ImportKind> importKind_;
   std::set<SourceName> importNames_;
   DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
+  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().
 
   // Storage for all Symbols. Every Symbol is in allSymbols and every Symbol*
   // or Symbol& points to one in there.
   static Symbols<1024> allSymbols;
 
   bool CanImport(const SourceName &) const;

flang/include/flang/Semantics/tools.h

inline bool IsStmtFunction(const Symbol &symbol) {
   return subprogram && subprogram->stmtFunction();
 }
 bool IsInStmtFunction(const Symbol &);
 bool IsStmtFunctionDummy(const Symbol &);
 bool IsStmtFunctionResult(const Symbol &);
 bool IsPointerDummy(const Symbol &);
 bool IsBindCProcedure(const Symbol &);
 bool IsBindCProcedure(const Scope &);
-bool IsProcName(const Symbol &symbol); // proc-name
+bool IsProcName(const Symbol &); // proc-name
 bool IsFunctionResult(const Symbol &);
 bool IsFunctionResultWithSameNameAsFunction(const Symbol &);
 bool IsExtensibleType(const DerivedTypeSpec *);
 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name);
 // Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV
 bool IsTeamType(const DerivedTypeSpec *);
 // Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
 bool IsIsoCType(const DerivedTypeSpec *);
 bool IsEventTypeOrLockType(const DerivedTypeSpec *);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
-bool IsInitialized(const Symbol &);
+bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
+bool IsAutomatic(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
     const std::function<bool(const Symbol &)> &predicate);
 const Symbol *FindUltimateComponent(
     const Symbol &symbol, const std::function<bool(const Symbol &)> &predicate);
 
 // Returns an immediate component of type that matches predicate, or nullptr.

 using SomeExpr = evaluate::Expr<evaluate::SomeType>;
 
 bool ExprHasTypeCategory(
     const SomeExpr &expr, const common::TypeCategory &type);
 bool ExprTypeKindIsDefault(
     const SomeExpr &expr, const SemanticsContext &context);
 
 struct GetExprHelper {
-  const SomeExpr *Get(const parser::Expr &);
-  const SomeExpr *Get(const parser::Variable &);
-  template <typename T> const SomeExpr *Get(const common::Indirection<T> &x) {
+  static const SomeExpr *Get(const parser::Expr &);
+  static const SomeExpr *Get(const parser::Variable &);
+  static const SomeExpr *Get(const parser::DataStmtConstant &);
+  template <typename T>
+  static const SomeExpr *Get(const common::Indirection<T> &x) {
     return Get(x.value());
   }
-  template <typename T> const SomeExpr *Get(const std::optional<T> &x) {
+  template <typename T> static const SomeExpr *Get(const std::optional<T> &x) {
     return x ? Get(*x) : nullptr;
   }
-  template <typename T> const SomeExpr *Get(const T &x) {
+  template <typename T> static const SomeExpr *Get(const T &x) {
     if constexpr (ConstraintTrait<T>) {
       return Get(x.thing);
     } else if constexpr (WrapperTrait<T>) {
       return Get(x.v);
     } else {
       return nullptr;
     }
   }
private:
   parser::CharBlock constructSourcePosition_{nullptr};
   const char *construct_{nullptr};
 
   parser::MessageFormattedText GetEnclosingConstructMsg();
   void SayWithConstruct(SemanticsContext &context,
       parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
       parser::CharBlock constructLocation);
 };
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

flang/lib/Evaluate/call.cpp

std::optional<DynamicType> ProcedureDesignator::GetType() const {
   } else {
     return DynamicType::From(GetSymbol());
   }
   return std::nullopt;
 }
 
 int ProcedureDesignator::Rank() const {
   if (const Symbol * symbol{GetSymbol()}) {
+    // Subtle: will be zero for functions returning procedure pointers
     return symbol->Rank();
   }
   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
     if (const auto &result{intrinsic->characteristics.value().functionResult}) {
       if (const auto *typeAndShape{result->GetTypeAndShape()}) {
         CHECK(!typeAndShape->attrs().test(
             characteristics::TypeAndShape::Attr::AssumedRank));
         return typeAndShape->Rank();
       }
+      // Otherwise, intrinsic returns a procedure pointer (e.g. NULL(MOLD=pptr))
     }
   }
-  DIE("ProcedureDesignator::Rank(): no case");
   return 0;
 }
 
 const Symbol *ProcedureDesignator::GetInterfaceSymbol() const {
   if (const Symbol * symbol{GetSymbol()}) {
     if (const auto *details{
             symbol->detailsIf<semantics::ProcEntityDetails>()}) {
       return details->interface().symbol();

flang/lib/Evaluate/characteristics.cpp

if ((!passIndex || j != *passIndex) &&
         dummyArguments[j] != that.dummyArguments[j]) {
       return false;
     }
   }
   return true;
 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+    const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
   Procedure result;
+  const auto &symbol{ResolveAssociations(original)};
   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
       {
           {semantics::Attr::PURE, Procedure::Attr::Pure},
           {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
       });
   if (result.attrs.test(Attr::Elemental) &&
       !symbol.attrs().test(semantics::Attr::IMPURE)) {

flang/lib/Evaluate/check-expression.cpp

public:
   using Base = AllTraverse<IsConstantExprHelper, true>;
   IsConstantExprHelper() : Base{*this} {}
   using Base::operator();
 
   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &inq) const {
     return IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
-    return IsNamedConstant(symbol) || IsImpliedDoIndex(symbol);
+    const auto &ultimate{symbol.GetUltimate()};
+    return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
+        IsInitialProcedureTarget(ultimate);
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
   template <typename T> bool operator()(const FunctionRef<T> &call) const {
     if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
       return intrinsic->name == "kind";
       // TODO: other inquiry intrinsics
     } else {
       return false;
     }
   }
   bool operator()(const StructureConstructor &constructor) const {
     for (const auto &[symRef, expr] : constructor) {
-      if (IsAllocatable(*symRef)) {
-        return IsNullPointer(expr.value());
-      } else if (IsPointer(*symRef)) {
-        return IsNullPointer(expr.value()) || IsInitialDataTarget(expr.value());
-      } else if (!(*this)(expr.value())) {
+      if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
         return false;
       }
     }
     return true;
   }
   bool operator()(const Component &component) const {
     return (*this)(component.base());
   }
   // Forbid integer division by zero in constants.
   template <int KIND>
   bool operator()(
       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
     using T = Type<TypeCategory::Integer, KIND>;
     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
       return !divisor->IsZero() && (*this)(division.left());
     } else {
       return false;
     }
   }
+
+  bool operator()(const Constant<SomeDerived> &) const { return true; }
+
+private:
+  bool IsConstantStructureConstructorComponent(
+      const Symbol &component, const Expr<SomeType> &expr) const {
+    if (IsAllocatable(component)) {
+      return IsNullPointer(expr);
+    } else if (IsPointer(component)) {
+      return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
+          IsInitialProcedureTarget(expr);
+    } else {
+      return (*this)(expr);
+    }
+  }
 };
 
 template <typename A> bool IsConstantExpr(const A &x) {
   return IsConstantExprHelper{}(x);
 }
 template bool IsConstantExpr(const Expr<SomeType> &);
 template bool IsConstantExpr(const Expr<SomeInteger> &);
 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
+template bool IsConstantExpr(const StructureConstructor &);
 
 // 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.
-// If messages are requested, errors may be generated without returning
-// a false result.
 class IsInitialDataTargetHelper
     : public AllTraverse<IsInitialDataTargetHelper, true> {
 public:
   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
   using Base::operator();
   explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
       : Base{*this}, messages_{m} {}
 
+  bool emittedMessage() const { return emittedMessage_; }
+
   bool operator()(const BOZLiteralConstant &) const { return false; }
   bool operator()(const NullPointer &) const { return true; }
   template <typename T> bool operator()(const Constant<T> &) const {
     return false;
   }
-  bool operator()(const semantics::Symbol &symbol) const {
+  bool operator()(const semantics::Symbol &symbol) {
     const Symbol &ultimate{symbol.GetUltimate()};
     if (IsAllocatable(ultimate)) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
             ultimate.name());
-      } else {
-        return false;
+        emittedMessage_ = true;
       }
+      return false;
     } else if (ultimate.Corank() > 0) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
             ultimate.name());
-      } else {
-        return false;
+        emittedMessage_ = true;
       }
+      return false;
     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
             ultimate.name());
-      } else {
-        return false;
+        emittedMessage_ = true;
       }
+      return false;
     } else if (!IsSaved(ultimate)) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
             ultimate.name());
-      } else {
-        return false;
+        emittedMessage_ = true;
       }
+      return false;
     }
     return true;
   }
   bool operator()(const StaticDataObject &) const { return false; }
   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &) const {
     return false;
   }
   bool operator()(const Triplet &x) const {
public:
   }
   template <typename T> bool operator()(const Parentheses<T> &x) const {
     return (*this)(x.left());
   }
   bool operator()(const Relational<SomeType> &) const { return false; }
 
 private:
   parser::ContextualMessages *messages_;
+  bool emittedMessage_{false};
 };
 
 bool IsInitialDataTarget(
     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
-  return IsInitialDataTargetHelper{messages}(x);
+  IsInitialDataTargetHelper helper{messages};
+  bool result{helper(x)};
+  if (!result && messages && !helper.emittedMessage()) {
+    messages->Say(
+        "An initial data target must be a designator with constant subscripts"_err_en_US);
+  }
+  return result;
+}
+
+bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
+  const auto &ultimate{symbol.GetUltimate()};
+  return std::visit(
+      common::visitors{
+          [](const semantics::SubprogramDetails &) { return true; },
+          [](const semantics::SubprogramNameDetails &) { return true; },
+          [&](const semantics::ProcEntityDetails &proc) {
+            return !semantics::IsPointer(ultimate) && !proc.isDummy();
+          },
+          [](const auto &) { return false; },
+      },
+      ultimate.details());
+}
+
+bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
+  if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
+    return !intrin->isRestrictedSpecific;
+  } else if (proc.GetComponent()) {
+    return false;
+  } else {
+    return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
+  }
+}
+
+bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
+  if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
+    return IsInitialProcedureTarget(*proc);
+  } else {
+    return IsNullPointer(expr);
+  }
 }
 
 // Specification expression validation (10.1.11(2), C1010)
 class CheckSpecificationExprHelper
     : public AnyTraverse<CheckSpecificationExprHelper,
           std::optional<std::string>> {
 public:
   using Result = std::optional<std::string>;

flang/lib/Evaluate/fold-implementation.h

if (const auto *object{
           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 symShape{GetShape(context_, symbol)}) {
-                    if (auto extents{AsConstantExtents(context_, *symShape)}) {
-                      *constant = constant->Reshape(std::move(*extents));
-                      CHECK(constant->Rank() == symbol.Rank());
-                    }
-                  }
-                }
+                  if (auto extents{GetConstantExtents(context_, symbol)}) {
                 if (constant->Rank() == symbol.Rank()) {
                   NamedEntity base{symbol};
                   if (auto lbounds{AsConstantExtents(
                           context_, GetLowerBounds(context_, base))}) {
                     constant->set_lbounds(*std::move(lbounds));
                   }
                 }
               }

flang/lib/Evaluate/fold.cpp

return std::visit(
             } else {
               return std::nullopt;
             }
           },
       },
       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 result{structure.derivedTypeSpec()};
+  StructureConstructor ctor{structure.derivedTypeSpec()};
+  bool constantExtents{true};
   for (auto &&[symbol, value] : std::move(structure)) {
-    result.Add(symbol, Fold(context, std::move(value.value())));
+    auto expr{Fold(context, std::move(value.value()))};
+    if (!IsProcedurePointer(symbol)) {
+      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;
+            }
+          } else {
+            constantExtents = false;
+          }
+        }
+      } else {
+        constantExtents = false;
+      }
+    }
+    ctor.Add(symbol, Fold(context, std::move(expr)));
+  }
+  if (constantExtents && IsConstantExpr(ctor)) {
+    return Expr<SomeDerived>{Constant<SomeDerived>{std::move(ctor)}};
+  } else {
+    return Expr<SomeDerived>{std::move(ctor)};
   }
-  return Expr<SomeDerived>{Constant<SomeDerived>{std::move(result)}};
 }
 
 Component FoldOperation(FoldingContext &context, Component &&component) {
   return {FoldOperation(context, std::move(component.base())),
       component.GetLastSymbol()};
 }
 
 NamedEntity FoldOperation(FoldingContext &context, NamedEntity &&x) {

flang/lib/Evaluate/shape.cpp

return std::visit(
             return (*this)(binding.symbol());
           },
           [&](const semantics::UseDetails &use) {
             return (*this)(use.symbol());
           },
           [&](const semantics::HostAssocDetails &assoc) {
             return (*this)(assoc.symbol());
           },
+          [](const semantics::TypeParamDetails &) { return Scalar(); },
           [](const auto &) { return Result{}; },
       },
       symbol.details());
 }
 
 auto GetShapeHelper::operator()(const Component &component) const -> Result {
   const Symbol &symbol{component.GetLastSymbol()};
   int rank{symbol.Rank()};
if (n != rn) {
             }
           }
         }
       }
     }
   }
   return true;
 }
+
+bool IncrementSubscripts(
+    ConstantSubscripts &indices, const ConstantSubscripts &extents) {
+  std::size_t rank(indices.size());
+  CHECK(rank <= extents.size());
+  for (std::size_t j{0}; j < rank; ++j) {
+    if (extents[j] < 1) {
+      return false;
+    }
+  }
+  for (std::size_t j{0}; j < rank; ++j) {
+    if (indices[j]++ < extents[j]) {
+      return true;
+    }
+    indices[j] = 1;
+  }
+  return false;
+}
 } // namespace Fortran::evaluate

flang/lib/Evaluate/tools.cpp

const Symbol *FindCommonBlockContaining(const Symbol &object) {
   const auto *details{object.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;
 }
 
 bool IsProcedurePointer(const Symbol &symbol) {
   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
 }
 
-bool IsSaved(const Symbol &symbol) {
-  auto scopeKind{symbol.owner().kind()};
-  if (scopeKind == Scope::Kind::Module || scopeKind == Scope::Kind::BlockData) {
+bool IsSaved(const Symbol &original) {
+  if (const Symbol * root{GetAssociationRoot(original)}) {
+    const Symbol &symbol{*root};
+    const Scope *scope{&symbol.owner()};
+    auto scopeKind{scope->kind()};
+    if (scopeKind == Scope::Kind::Module) {
+      return true; // BLOCK DATA entities must all be in COMMON, handled below
+    } else if (symbol.attrs().test(Attr::SAVE)) {
       return true;
     } else if (scopeKind == Scope::Kind::DerivedType) {
       return false; // this is a component
     } else if (IsNamedConstant(symbol)) {
       return false;
-  } else if (symbol.attrs().test(Attr::SAVE)) {
-    return true;
     } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
                object && object->init()) {
       return true;
     } else if (IsProcedurePointer(symbol) &&
         symbol.get<ProcEntityDetails>().init()) {
       return true;
     } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
                block && block->attrs().test(Attr::SAVE)) {
       return true;
-  } else {
+    } else if (IsDummy(symbol)) {
       return false;
+    } else {
+      for (; !scope->IsGlobal(); scope = &scope->parent()) {
+        if (scope->hasSAVE()) {
+          return true;
+        }
+      }
     }
   }
+  return false;
+}
 
 bool IsDummy(const Symbol &symbol) {
   return std::visit(
       common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
           [](const ObjectEntityDetails &x) { return x.isDummy(); },
           [](const ProcEntityDetails &x) { return x.isDummy(); },
           [](const HostAssocDetails &x) { return IsDummy(x.symbol()); },
           [](const auto &) { return false; }},
       symbol.details());
 }
 
 int CountLenParameters(const DerivedTypeSpec &type) {
   return std::count_if(type.parameters().begin(), type.parameters().end(),
       [](const auto &pair) { return pair.second.isLen(); });
 }
 
+int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
+  return std::count_if(
+      type.parameters().begin(), type.parameters().end(), [](const auto &pair) {
+        if (!pair.second.isLen()) {
+          return false;
+        } else if (const auto &expr{pair.second.GetExplicit()}) {
+          return !IsConstantExpr(*expr);
+        } else {
+          return true;
+        }
+      });
+}
+
 const Symbol &GetUsedModule(const UseDetails &details) {
   return DEREF(details.symbol().owner().symbol());
 }
 
 } // namespace Fortran::semantics

flang/lib/Evaluate/type.cpp

DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
   default:
     CRASH_NO_CASE;
   }
   return *this;
 }
 
 bool DynamicType::RequiresDescriptor() const {
   return IsPolymorphic() || IsUnknownLengthCharacter() ||
-      (derived_ && CountLenParameters(*derived_) > 0);
+      (derived_ && CountNonConstantLenParameters(*derived_) > 0);
 }
 
 bool DynamicType::HasDeferredTypeParameter() const {
   if (derived_) {
     for (const auto &pair : derived_->parameters()) {
       if (pair.second.isDeferred()) {
         return true;
       }

flang/lib/Parser/Fortran-parsers.cpp

 //        signed-int-literal-constant | signed-real-literal-constant |
 //        null-init | initial-data-target | structure-constructor
 // TODO: Some structure constructors can be misrecognized as array
 // references into constant subobjects.
 TYPE_PARSER(sourced(first(
     construct<DataStmtConstant>(scalar(Parser<ConstantValue>{})),
     construct<DataStmtConstant>(nullInit),
     construct<DataStmtConstant>(scalar(constantSubobject)) / !"("_tok,
-    construct<DataStmtConstant>(Parser<StructureConstructor>{}),
+    construct<DataStmtConstant>(constant(Parser<StructureConstructor>{})),
     construct<DataStmtConstant>(signedRealLiteralConstant),
     construct<DataStmtConstant>(signedIntLiteralConstant),
     extension<LanguageFeature::SignedComplexLiteral>(
         construct<DataStmtConstant>(Parser<SignedComplexLiteralConstant>{})),
     construct<DataStmtConstant>(initialDataTarget))))
 
 // R848 dimension-stmt ->
 //        DIMENSION [::] array-name ( array-spec )

flang/lib/Parser/tools.cpp

return std::visit(
       x.u);
 }
 
 const Name &GetLastName(const AllocateObject &x) {
   return std::visit(
       [](const auto &y) -> const Name & { return GetLastName(y); }, x.u);
 }
 
+const Name &GetFirstName(const Name &x) { return x; }
+
+const Name &GetFirstName(const StructureComponent &x) {
+  return GetFirstName(x.base);
+}
+
+const Name &GetFirstName(const DataRef &x) {
+  return std::visit(
+      common::visitors{
+          [](const Name &name) -> const Name & { return name; },
+          [](const common::Indirection<StructureComponent> &sc)
+              -> const Name & { return GetFirstName(sc.value()); },
+          [](const common::Indirection<ArrayElement> &sc) -> const Name & {
+            return GetFirstName(sc.value().base);
+          },
+          [](const common::Indirection<CoindexedNamedObject> &ci)
+              -> const Name & { return GetFirstName(ci.value().base); },
+      },
+      x.u);
+}
+
+const Name &GetFirstName(const Substring &x) {
+  return GetFirstName(std::get<DataRef>(x.t));
+}
+
+const Name &GetFirstName(const Designator &x) {
+  return std::visit(
+      [](const auto &y) -> const Name & { return GetFirstName(y); }, x.u);
+}
+
+const Name &GetFirstName(const ProcComponentRef &x) {
+  return GetFirstName(x.v.thing);
+}
+
+const Name &GetFirstName(const ProcedureDesignator &x) {
+  return std::visit(
+      [](const auto &y) -> const Name & { return GetFirstName(y); }, x.u);
+}
+
+const Name &GetFirstName(const Call &x) {
+  return GetFirstName(std::get<ProcedureDesignator>(x.t));
+}
+
+const Name &GetFirstName(const FunctionReference &x) {
+  return GetFirstName(x.v);
+}
+
+const Name &GetFirstName(const Variable &x) {
+  return std::visit(
+      [](const auto &indirect) -> const Name & {
+        return GetFirstName(indirect.value());
+      },
+      x.u);
+}
+
 const CoindexedNamedObject *GetCoindexedNamedObject(const DataRef &base) {
   return std::visit(
       common::visitors{
           [](const Name &) -> const CoindexedNamedObject * { return nullptr; },
           [](const common::Indirection<CoindexedNamedObject> &x)
               -> const CoindexedNamedObject * { return &x.value(); },
           [](const auto &x) -> const CoindexedNamedObject * {
             return GetCoindexedNamedObject(x.value().base);

flang/lib/Semantics/check-data.h

 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/tools.h"
 
 namespace Fortran::semantics {
 class DataChecker : public virtual BaseChecker {
 public:
   explicit DataChecker(SemanticsContext &context) : exprAnalyzer_{context} {}
-  void Leave(const parser::DataStmtRepeat &);
-  void Leave(const parser::DataStmtConstant &);
   void Leave(const parser::DataStmtObject &);
   void Enter(const parser::DataImpliedDo &);
   void Leave(const parser::DataImpliedDo &);
   void Leave(const parser::DataIDoObject &);
 
 private:
   evaluate::ExpressionAnalyzer exprAnalyzer_;
   template <typename T> void CheckIfConstantSubscript(const T &);
   void CheckSubscript(const parser::SectionSubscript &);
   bool CheckAllSubscriptsInDataRef(const parser::DataRef &, parser::CharBlock);
 };
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_CHECK_DATA_H_

flang/lib/Semantics/check-data.cpp

 //===-- lib/Semantics/check-data.cpp --------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "check-data.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Semantics/expression.h"
 
 namespace Fortran::semantics {
 
-void DataChecker::Leave(const parser::DataStmtConstant &dataConst) {
-  if (auto *structure{
-          std::get_if<parser::StructureConstructor>(&dataConst.u)}) {
-    for (const auto &component :
-        std::get<std::list<parser::ComponentSpec>>(structure->t)) {
-      const parser::Expr &parsedExpr{
-          std::get<parser::ComponentDataSource>(component.t).v.value()};
-      if (const auto *expr{GetExpr(parsedExpr)}) {
-        if (!evaluate::IsConstantExpr(*expr)) { // C884
-          exprAnalyzer_.Say(parsedExpr.source,
-              "Structure constructor in data value must be a constant expression"_err_en_US);
-        }
-      }
-    }
-  }
-}
-
 // Ensures that references to an implied DO loop control variable are
 // represented as such in the "body" of the implied DO loop.
 void DataChecker::Enter(const parser::DataImpliedDo &x) {
   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
   int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
   if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
     kind = dynamicType->kind();
   }
void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
   if (const auto *var{
           std::get_if<common::Indirection<parser::Variable>>(&dataObject.u)}) {
     if (auto expr{exprAnalyzer_.Analyze(*var)}) {
       DataVarChecker{exprAnalyzer_.context(),
           parser::FindSourceLocation(dataObject)}(expr);
     }
   }
 }
-
-void DataChecker::Leave(const parser::DataStmtRepeat &dataRepeat) {
-  if (const auto *designator{parser::Unwrap<parser::Designator>(dataRepeat)}) {
-    if (auto *dataRef{std::get_if<parser::DataRef>(&designator->u)}) {
-      if (MaybeExpr checked{exprAnalyzer_.Analyze(*dataRef)}) {
-        auto expr{evaluate::Fold(
-            exprAnalyzer_.GetFoldingContext(), std::move(checked))};
-        if (auto i64{ToInt64(expr)}) {
-          if (*i64 < 0) { // C882
-            exprAnalyzer_.Say(designator->source,
-                "Repeat count for data value must not be negative"_err_en_US);
-          }
-        }
-      }
-    }
-  }
-}
 } // namespace Fortran::semantics

flang/lib/Semantics/check-declarations.cpp

if (IsDummy(symbol)) {
     if (IsNamedConstant(symbol)) {
       messages_.Say(
           "A dummy argument may not also be a named constant"_err_en_US);
     }
     if (IsSaved(symbol)) {
       messages_.Say(
           "A dummy argument may not have the SAVE attribute"_err_en_US);
     }
+  } else if (IsFunctionResult(symbol)) {
+    if (IsSaved(symbol)) {
+      messages_.Say(
+          "A function result may not have the SAVE attribute"_err_en_US);
+    }
   }
   if (symbol.owner().IsDerivedType() &&
       (symbol.attrs().test(Attr::CONTIGUOUS) &&
           !(IsPointer(symbol) && symbol.Rank() > 0))) { // C752
     messages_.Say(
         "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US);
   }
 }
if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
         }
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
   }
   if (symbol.owner().kind() != Scope::Kind::DerivedType &&
-      IsInitialized(symbol)) {
-    if (details.commonBlock()) {
-      if (details.commonBlock()->name().empty()) {
-        messages_.Say(
-            "A variable in blank COMMON should not be initialized"_en_US);
-      }
-    } else 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 {
-        messages_.Say(
-            "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
-      }
-    }
-  }
+      IsInitialized(symbol, true /*ignore DATA, already caught*/)) { // C808
+    if (IsAutomatic(symbol)) {
+      messages_.Say("An automatic variable must not be initialized"_err_en_US);
+    } else if (IsDummy(symbol)) {
+      messages_.Say("A dummy argument must not be initialized"_err_en_US);
+    } else if (IsFunctionResult(symbol)) {
+      messages_.Say("A function result must not be initialized"_err_en_US);
+    } else if (IsInBlankCommon(symbol)) {
+  }
+  if (symbol.owner().kind() == Scope::Kind::BlockData &&
+      IsInitialized(symbol)) {
+    } else if (!FindCommonBlockContaining(symbol)) {
   if (const DeclTypeSpec * type{details.type()}) { // C708
     if (type->IsPolymorphic() &&
         !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
             IsDummy(symbol))) {
       messages_.Say("CLASS entity '%s' must be a dummy argument or have "
                     "ALLOCATABLE or POINTER attribute"_err_en_US,
           symbol.name());
     }
void CheckHelper::CheckProcEntity(
   if (symbol.attrs().test(Attr::POINTER)) {
     if (const Symbol * interface{details.interface().symbol()}) {
       if (interface->attrs().test(Attr::ELEMENTAL) &&
           !interface->attrs().test(Attr::INTRINSIC)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
+  } else if (symbol.attrs().test(Attr::SAVE)) {
+    messages_.Say(
+        "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
+        symbol.name());
   }
 }
 
 // When a module subprogram has the MODULE prefix the following must match
 // with the corresponding separate module procedure interface body:
 // - C1549: characteristics and dummy argument names
 // - C1550: binding label
 // - C1551: NON_RECURSIVE prefix

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

void Post(const parser::BlockConstruct &blockConstruct) {
     const auto &endBlockStmt{
         std::get<parser::Statement<parser::EndBlockStmt>>(blockConstruct.t)};
     const Scope &blockScope{context_.FindScope(endBlockStmt.source)};
     const Scope &doScope{context_.FindScope(doConcurrentSourcePosition_)};
     if (DoesScopeContain(&doScope, blockScope)) {
       const char *reason{"block exit"};
       for (auto &pair : blockScope) {
         const Symbol &entity{*pair.second};
-        if (IsAllocatable(entity) && !entity.attrs().test(Attr::SAVE) &&
+        if (IsAllocatable(entity) && !IsSaved(entity) &&
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
           SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
         }
         if (HasImpureFinal(entity)) {
           SayDeallocateWithImpureFinal(entity, reason);
         }
       }
     }

flang/lib/Semantics/expression.cpp

if (MaybeExpr result{Analyze(d.u)}) {
     return result;
   }
   return std::nullopt;
 }
 
 // A utility subroutine to repackage optional expressions of various levels
 // of type specificity as fully general MaybeExpr values.
 template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
-  return std::make_optional(AsGenericExpr(std::move(x)));
+  return AsGenericExpr(std::move(x));
 }
 template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
   if (x) {
     return AsMaybeExpr(std::move(*x));
   }
   return std::nullopt;
 }
 

 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(
     const parser::SignedRealLiteralConstant &x) {
   if (auto result{Analyze(std::get<parser::RealLiteralConstant>(x.t))}) {
     auto &realExpr{std::get<Expr<SomeReal>>(result->u)};
     if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {
       if (sign == parser::Sign::Negative) {
-        return {AsGenericExpr(-std::move(realExpr))};
+        return AsGenericExpr(-std::move(realExpr));
       }
     }
     return result;
   }
   return std::nullopt;
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(

 MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &x) {
   return Expr<SomeType>{NullPointer{}};
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
   return Analyze(x.value());
 }
 
+MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
+  if (const auto &repeat{
+          std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
+    x.repetitions = 0;
+    if (MaybeExpr expr{Analyze(repeat->u)}) {
+      Expr<SomeType> folded{Fold(std::move(*expr))};
+      if (auto value{ToInt64(folded)}) {
+        if (*value >= 0) { // C882
+          x.repetitions = *value;
+        } else {
+          Say(FindSourceLocation(repeat),
+              "Repeat count (%jd) for data value must not be negative"_err_en_US,
+              *value);
+        }
+      }
+    }
+  }
+  return Analyze(std::get<parser::DataStmtConstant>(x.t));
+}
+
 // Substring references
 std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
     const std::optional<parser::ScalarIntExpr> &bound) {
   if (bound) {
     if (MaybeExpr expr{Analyze(*bound)}) {
       if (expr->Rank() > 1) {
         Say("substring bound expression has rank %d"_err_en_US, expr->Rank());
       }
if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {
             auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};
             CHECK(DEREF(cp).size() == 1);
             StaticDataObject::Pointer staticData{StaticDataObject::Create()};
             staticData->set_alignment(Result::kind)
                 .set_itemBytes(Result::kind)
                 .Push(cp->GetScalarValue().value());
             Substring substring{std::move(staticData), std::move(lower.value()),
                 std::move(upper.value())};
-            return AsGenericExpr(Expr<SomeCharacter>{
-                Expr<Result>{Designator<Result>{std::move(substring)}}});
+            return AsGenericExpr(
+                Expr<Result>{Designator<Result>{std::move(substring)}});
           },
           std::move(charExpr->u));
     }
   }
   return std::nullopt;
 }
 
 // Subscripted array references
if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {
                 using PartType = typename ResultType<decltype(z)>::Part;
                 auto part{kind == MiscKind::ComplexPartRe
                         ? ComplexPart::Part::RE
                         : ComplexPart::Part::IM};
                 return AsCategoryExpr(Designator<PartType>{
                     ComplexPart{std::move(*dataRef), part}});
               },
               zExpr->u)};
-          return {AsGenericExpr(std::move(realExpr))};
+          return AsGenericExpr(std::move(realExpr));
         }
       }
     } else if (kind == MiscKind::KindParamInquiry ||
         kind == MiscKind::LenParamInquiry) {
       // Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x)
       return MakeFunctionRef(
           name, ActualArguments{ActualArgument{std::move(*base)}});
     } else {
MaybeExpr ExpressionAnalyzer::Analyze(
   // initialize X or A by name, but not both.
   auto components{semantics::OrderedComponentIterator{spec}};
   auto nextAnonymous{components.begin()};
 
   std::set<parser::CharBlock> unavailable;
   bool anyKeyword{false};
   StructureConstructor result{spec};
   bool checkConflicts{true}; // until we hit one
+  auto &messages{GetContextualMessages()};
 
   for (const auto &component :
       std::get<std::list<parser::ComponentSpec>>(structure.t)) {
     const parser::Expr &expr{
         std::get<parser::ComponentDataSource>(component.t).v.value()};
     parser::CharBlock source{expr.source};
-    auto &messages{GetContextualMessages()};
     auto restorer{messages.SetLocation(source)};
     const Symbol *symbol{nullptr};
     MaybeExpr value{Analyze(expr)};
     std::optional<DynamicType> valueType{DynamicType::From(value)};
     if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
       anyKeyword = true;
       source = kw->v.source;
       symbol = kw->v.symbol;
if (symbol) {
           continue;
         }
         if (IsPointer(*symbol)) {
           semantics::CheckPointerAssignment(
               GetFoldingContext(), *symbol, *value); // C7104, C7105
           result.Add(*symbol, Fold(std::move(*value)));
         } else if (MaybeExpr converted{
                        ConvertToType(*symbol, std::move(*value))}) {
+          if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
+            if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
+              if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
+                AttachDeclaration(
+                    Say(expr.source,
+                        "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
+                        symbol->name()),
+                    *symbol);
+              } else if (CheckConformance(messages, *componentShape,
+                             *valueShape, "component", "value")) {
+                if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
+                    !IsExpandableScalar(*converted)) {
+                  AttachDeclaration(
+                      Say(expr.source,
+                          "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
+                          symbol->name()),
+                      *symbol);
+                } else {
                   result.Add(*symbol, std::move(*converted));
+                }
+              }
+            } else {
+              Say(expr.source, "Shape of value cannot be determined"_err_en_US);
+            }
+          } else {
+            AttachDeclaration(
+                Say(expr.source,
+                    "Shape of component '%s' cannot be determined"_err_en_US,
+                    symbol->name()),
+                *symbol);
+          }
         } else if (IsAllocatable(*symbol) &&
             std::holds_alternative<NullPointer>(value->u)) {
           // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE
         } else if (auto symType{DynamicType::From(symbol)}) {
           if (valueType) {
             AttachDeclaration(
                 Say(expr.source,
                     "Value in structure constructor of type %s is "
if (actuals_.size() == 1) {
     }
   }
 }
 
 std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
   if (std::optional<DynamicType> type{GetType(i)}) {
     return type->category() == TypeCategory::Derived
         ? "TYPE("s + type->AsFortran() + ')'
-        : type->category() == TypeCategory::Character
-            ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
-            : ToUpperCase(type->AsFortran());
   } else {
     return "untyped";
   }
 }
 
 bool ArgumentAnalyzer::AnyUntypedOperand() {
   for (const auto &actual : actuals_) {
     if (!actual.value().GetType()) {

 }
 const evaluate::Assignment *AnalyzePointerAssignmentStmt(
     SemanticsContext &context, const parser::PointerAssignmentStmt &stmt) {
   return evaluate::ExpressionAnalyzer{context}.Analyze(stmt);
 }
 
 ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
 
+bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
+  parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
+  const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
+  auto name{bounds.name.thing.thing};
+  int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
+  if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
+    if (dynamicType->category() == TypeCategory::Integer) {
+      kind = dynamicType->kind();
+    }
+  }
+  exprAnalyzer_.AddImpliedDo(name.source, kind);
+  parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
+  exprAnalyzer_.RemoveImpliedDo(name.source);
+  return false;
+}
+
 bool ExprChecker::Walk(const parser::Program &program) {
   parser::Walk(program, *this);
   return !context_.AnyFatalError();
 }
 } // namespace Fortran::semantics

flang/lib/Semantics/pointer-assignment.h

 namespace Fortran::evaluate {
 class FoldingContext;
 }
 
 namespace Fortran::semantics {
 
 class Symbol;
 
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
     evaluate::FoldingContext &, const evaluate::Assignment &);
-void CheckPointerAssignment(
+bool CheckPointerAssignment(evaluate::FoldingContext &, const SomeExpr &lhs,
+    const SomeExpr &rhs, bool isBoundsRemapping = false);
+bool CheckPointerAssignment(
     evaluate::FoldingContext &, const Symbol &lhs, const SomeExpr &rhs);
-void CheckPointerAssignment(evaluate::FoldingContext &,
+bool CheckPointerAssignment(evaluate::FoldingContext &,
     parser::CharBlock source, const std::string &description,
     const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs);
 
+// Checks whether an expression is a valid static initializer for a
+// particular pointer designator.
+bool CheckInitialTarget(
+    evaluate::FoldingContext &, const SomeExpr &pointer, const SomeExpr &init);
+
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_

flang/lib/Semantics/pointer-assignment.cpp

PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs)
     set_lhsType(TypeAndShape::Characterize(lhs, context));
     set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
     set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
   }
   PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
   PointerAssignmentChecker &set_isContiguous(bool);
   PointerAssignmentChecker &set_isVolatile(bool);
   PointerAssignmentChecker &set_isBoundsRemapping(bool);
-  void Check(const SomeExpr &);
+  bool Check(const SomeExpr &);
 
 private:
-  template <typename T> void Check(const T &);
-  template <typename T> void Check(const evaluate::Expr<T> &);
-  template <typename T> void Check(const evaluate::FunctionRef<T> &);
-  template <typename T> void Check(const evaluate::Designator<T> &);
-  void Check(const evaluate::NullPointer &);
-  void Check(const evaluate::ProcedureDesignator &);
-  void Check(const evaluate::ProcedureRef &);
+  template <typename T> bool Check(const T &);
+  template <typename T> bool Check(const evaluate::Expr<T> &);
+  template <typename T> bool Check(const evaluate::FunctionRef<T> &);
+  template <typename T> bool Check(const evaluate::Designator<T> &);
+  bool Check(const evaluate::NullPointer &);
+  bool Check(const evaluate::ProcedureDesignator &);
+  bool Check(const evaluate::ProcedureRef &);
   // Target is a procedure
-  void Check(
+  bool Check(
       parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
   bool LhsOkForUnlimitedPoly() const;
   template <typename... A> parser::Message *Say(A &&...);
 
   evaluate::FoldingContext &context_;
   const parser::CharBlock source_;
   const std::string description_;
   const Symbol *lhs_{nullptr};

 }
 
 PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
     bool isBoundsRemapping) {
   isBoundsRemapping_ = isBoundsRemapping;
   return *this;
 }
 
-template <typename T> void PointerAssignmentChecker::Check(const T &) {
+template <typename T> bool PointerAssignmentChecker::Check(const T &) {
   // Catch-all case for really bad target expression
   Say("Target associated with %s must be a designator or a call to a"
       " pointer-valued function"_err_en_US,
       description_);
+  return false;
 }
 
 template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
-  std::visit([&](const auto &x) { Check(x); }, x.u);
+bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
+  return std::visit([&](const auto &x) { return Check(x); }, x.u);
 }
 
-void PointerAssignmentChecker::Check(const SomeExpr &rhs) {
+bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
   if (HasVectorSubscript(rhs)) { // C1025
     Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
+    return false;
   } else if (ExtractCoarrayRef(rhs)) { // C1026
     Say("A coindexed object may not be a pointer target"_err_en_US);
+    return false;
   } else {
-    std::visit([&](const auto &x) { Check(x); }, rhs.u);
+    return std::visit([&](const auto &x) { return Check(x); }, rhs.u);
   }
 }
 
-void PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
-  // P => NULL() without MOLD=; always OK
+bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
+  return true; // P => NULL() without MOLD=; always OK
 }
 
 template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
+bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
   std::string funcName;
   const auto *symbol{f.proc().GetSymbol()};
   if (symbol) {
     funcName = symbol->name().ToString();
   } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
     funcName = intrinsic->name;
   }
   auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
   if (!proc) {
-    return;
+    return false;
   }
   std::optional<MessageFixedText> msg;
   const auto &funcResult{proc->functionResult}; // C1025
   if (!funcResult) {
     msg = "%s is associated with the non-existent result of reference to"
           " procedure"_err_en_US;
   } else if (procedure_) {
     // Shouldn't be here in this function unless lhs is an object pointer.
if (!funcResult) {
     if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape)) {
       msg = "%s is associated with the result of a reference to function '%s'"
             " whose pointer result has an incompatible type or shape"_err_en_US;
     }
   }
   if (msg) {
     auto restorer{common::ScopedSet(lhs_, symbol)};
     Say(*msg, description_, funcName);
+    return false;
   }
+  return true;
 }
 
 template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
+bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
   const Symbol *last{d.GetLastSymbol()};
   const Symbol *base{d.GetBaseObject().symbol()};
   if (!last || !base) {
     // P => "character literal"(1:3)
     context_.messages().Say("Pointer target is not a named entity"_err_en_US);
-    return;
+    return false;
   }
   std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
   if (procedure_) {
     // Shouldn't be here in this function unless lhs is an object pointer.
     msg = "In assignment to procedure %s, the target is not a procedure or"
           " procedure pointer"_err_en_US;
   } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
     msg = "In assignment to object %s, the target '%s' is not an object with"
if (msg) {
     if (auto *m{std::get_if<MessageFixedText>(&*msg)}) {
       std::string buf;
       llvm::raw_string_ostream ss{buf};
       d.AsFortran(ss);
       Say(*m, description_, ss.str());
     } else {
       Say(std::get<MessageFormattedText>(*msg));
     }
+    return false;
   }
+  return true;
 }
 
 // Compare procedure characteristics for equality except that lhs may be
 // Pure or Elemental when rhs is not.
 static bool CharacteristicsMatch(const Procedure &lhs, const Procedure &rhs) {
   using Attr = Procedure::Attr;
   auto lhsAttrs{rhs.attrs};
   lhsAttrs.set(
       Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
   lhsAttrs.set(Attr::Elemental,
       lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
   return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
       lhs.dummyArguments == rhs.dummyArguments;
 }
 
 // Common handling for procedure pointer right-hand sides
-void PointerAssignmentChecker::Check(
+bool PointerAssignmentChecker::Check(
     parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
   std::optional<MessageFixedText> msg;
   if (!procedure_) {
     msg = "In assignment to object %s, the target '%s' is a procedure"
           " designator"_err_en_US;
   } else if (!rhsProcedure) {
     msg = "In assignment to procedure %s, the characteristics of the target"
           " procedure '%s' could not be determined"_err_en_US;
if (!procedure_) {
     msg = "Procedure %s with implicit interface may not be associated with"
           " procedure designator '%s' with explicit interface"_err_en_US;
   } else {
     msg = "Procedure %s associated with incompatible procedure"
           " designator '%s'"_err_en_US;
   }
   if (msg) {
     Say(std::move(*msg), description_, rhsName);
+    return false;
   }
+  return true;
 }
 
-void PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
+bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
   if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
-    Check(d.GetName(), false, &*chars);
+    return Check(d.GetName(), false, &*chars);
   } else {
-    Check(d.GetName(), false);
+    return Check(d.GetName(), false);
   }
 }
 
-void PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
+bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
   const Procedure *procedure{nullptr};
   auto chars{Procedure::Characterize(ref, context_.intrinsics())};
   if (chars) {
     procedure = &*chars;
     if (chars->functionResult) {
       if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
         procedure = proc;
       }
     }
   }
-  Check(ref.proc().GetName(), true, procedure);
+  return Check(ref.proc().GetName(), true, procedure);
 }
 
 // The target can be unlimited polymorphic if the pointer is, or if it is
 // a non-extensible derived type.
 bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
   const auto &type{lhsType_->type()};
   if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
     return false;
static bool CheckPointerBounds(
   if (isBoundsRemapping && rhs.Rank() != 1 &&
       !evaluate::IsSimplyContiguous(rhs, context.intrinsics())) {
     messages.Say("Pointer bounds remapping target must have rank 1 or be"
                  " simply contiguous"_err_en_US); // 10.2.2.3(9)
   }
   return isBoundsRemapping;
 }
 
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
     evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
-  const SomeExpr &lhs{assignment.lhs};
-  const SomeExpr &rhs{assignment.rhs};
+  return CheckPointerAssignment(context, assignment.lhs, assignment.rhs,
+      CheckPointerBounds(context, assignment));
+}
+
+bool CheckPointerAssignment(evaluate::FoldingContext &context,
+    const SomeExpr &lhs, const SomeExpr &rhs, bool isBoundsRemapping) {
   const Symbol *pointer{GetLastSymbol(lhs)};
   if (!pointer) {
-    return; // error was reported
+    return false; // error was reported
   }
   if (!IsPointer(*pointer)) {
     evaluate::SayWithDeclaration(context.messages(), *pointer,
         "'%s' is not a pointer"_err_en_US, pointer->name());
-    return;
+    return false;
   }
   if (pointer->has<ProcEntityDetails>() && evaluate::ExtractCoarrayRef(lhs)) {
     context.messages().Say( // C1027
         "Procedure pointer may not be a coindexed object"_err_en_US);
-    return;
+    return false;
   }
-  bool isBoundsRemapping{CheckPointerBounds(context, assignment)};
-  PointerAssignmentChecker{context, *pointer}
+  return PointerAssignmentChecker{context, *pointer}
       .set_isBoundsRemapping(isBoundsRemapping)
       .Check(rhs);
 }
 
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
     evaluate::FoldingContext &context, const Symbol &lhs, const SomeExpr &rhs) {
   CHECK(IsPointer(lhs));
-  PointerAssignmentChecker{context, lhs}.Check(rhs);
+  return PointerAssignmentChecker{context, lhs}.Check(rhs);
 }
 
-void CheckPointerAssignment(evaluate::FoldingContext &context,
+bool CheckPointerAssignment(evaluate::FoldingContext &context,
     parser::CharBlock source, const std::string &description,
     const DummyDataObject &lhs, const SomeExpr &rhs) {
-  PointerAssignmentChecker{context, source, description}
+  return PointerAssignmentChecker{context, source, description}
       .set_lhsType(common::Clone(lhs.type))
       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
       .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
       .Check(rhs);
 }
 
+bool CheckInitialTarget(evaluate::FoldingContext &context,
+    const SomeExpr &pointer, const SomeExpr &init) {
+  return evaluate::IsInitialDataTarget(init, &context.messages()) &&
+      CheckPointerAssignment(context, pointer, init);
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/resolve-names.cpp

 //===-- lib/Semantics/resolve-names.cpp -----------------------------------===//
-//
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "resolve-names.h"
 #include "assignment.h"
 #include "check-omp-structure.h"
 #include "mod-file.h"
+#include "pointer-assignment.h"
 #include "program-tree.h"
 #include "resolve-names-utils.h"
 #include "rewrite-parse-tree.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Common/default-kinds.h"
 #include "flang/Common/indirection.h"
 #include "flang/Common/restorer.h"
 #include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/common.h"
+#include "flang/Evaluate/fold-designator.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Parser/tools.h"
 #include "flang/Semantics/attr.h"
public:
   bool Pre(const parser::EquivalenceStmt &);
   bool Pre(const parser::SaveStmt &);
   bool Pre(const parser::BasedPointerStmt &);
 
   void PointerInitialization(
       const parser::Name &, const parser::InitialDataTarget &);
   void PointerInitialization(
       const parser::Name &, const parser::ProcPointerInit &);
+  void NonPointerInitialization(
+      const parser::Name &, const parser::ConstantExpr &, bool inComponentDecl);
   void CheckExplicitInterface(const parser::Name &);
   void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
 
   const parser::Name *ResolveDesignator(const parser::Designator &);
 
 protected:
   bool BeginDecl();
   void EndDecl();
private:
   Symbol &MakeCommonBlockSymbol(const parser::Name &);
   void CheckCommonBlockDerivedType(const SourceName &, const Symbol &);
   std::optional<MessageFixedText> CheckSaveAttr(const Symbol &);
   Attrs HandleSaveName(const SourceName &, Attrs);
   void AddSaveName(std::set<SourceName> &, const SourceName &);
   void SetSaveAttr(Symbol &);
   bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
   const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
-  void CheckInitialDataTarget(const Symbol &, const SomeExpr &, SourceName);
+  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);
 
   // Declare an object or procedure entity.
   // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
   template <typename T>

 public:
   bool Pre(const parser::ConcurrentHeader &);
   bool Pre(const parser::LocalitySpec::Local &);
   bool Pre(const parser::LocalitySpec::LocalInit &);
   bool Pre(const parser::LocalitySpec::Shared &);
   bool Pre(const parser::AcSpec &);
   bool Pre(const parser::AcImpliedDo &);
   bool Pre(const parser::DataImpliedDo &);
+  bool Pre(const parser::DataIDoObject &);
   bool Pre(const parser::DataStmtObject &);
   bool Pre(const parser::DataStmtValue &);
   bool Pre(const parser::DoConstruct &);
   void Post(const parser::DoConstruct &);
   bool Pre(const parser::ForallConstruct &);
   void Post(const parser::ForallConstruct &);
   bool Pre(const parser::ForallStmt &);
   void Post(const parser::ForallStmt &);
for (auto &set : equivSets.sets()) {
     }
   }
   equivalenceSets_.clear();
 }
 
 bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
   if (x.v.empty()) {
     saveInfo_.saveAll = currStmtSource();
+    currScope().set_hasSAVE();
   } else {
     for (const parser::SavedEntity &y : x.v) {
       auto kind{std::get<parser::SavedEntity::Kind>(y.t)};
       const auto &name{std::get<parser::Name>(y.t)};
       if (kind == parser::SavedEntity::Kind::Common) {
         MakeCommonBlockSymbol(name);
         AddSaveName(saveInfo_.commons, name.source);
       } else {
if (!symbol) {
       // error was reported
     } else if (saveInfo_.saveAll) {
       // C889 - note that pgi, ifort, xlf do not enforce this constraint
       Say2(name,
           "Explicit SAVE of '%s' is redundant due to global SAVE statement"_err_en_US,
           *saveInfo_.saveAll, "Global SAVE statement"_en_US);
     } else if (auto msg{CheckSaveAttr(*symbol)}) {
       Say(name, std::move(*msg));
+      context().SetError(*symbol);
     } else {
       SetSaveAttr(*symbol);
     }
   }
   for (const SourceName &name : saveInfo_.commons) {
     if (auto *symbol{currScope().FindCommonBlock(name)}) {
       auto &objects{symbol->get<CommonBlockDetails>().objects()};
       if (objects.empty()) {
std::optional<MessageFixedText> DeclarationVisitor::CheckSaveAttr(
   } else if (symbol.has<ProcEntityDetails>() &&
       !symbol.attrs().test(Attr::POINTER)) {
     return "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US;
   } else {
     return std::nullopt;
   }
 }
 
-// Instead of setting SAVE attribute, record the name in saveInfo_.entities.
+// Record SAVEd names in saveInfo_.entities.
 Attrs DeclarationVisitor::HandleSaveName(const SourceName &name, Attrs attrs) {
   if (attrs.test(Attr::SAVE)) {
-    attrs.set(Attr::SAVE, false);
     AddSaveName(saveInfo_.entities, name);
   }
   return attrs;
 }
 
 // Record a name in a set of those to be saved.
 void DeclarationVisitor::AddSaveName(
     std::set<SourceName> &set, const SourceName &name) {
bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
   auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(x.t)};
   auto &bounds{std::get<parser::DataImpliedDo::Bounds>(x.t)};
   DeclareStatementEntity(bounds.name.thing.thing, type);
   Walk(bounds);
   Walk(objects);
   return false;
 }
 
+// Sets InDataStmt flag on a variable (or misidentified function) in a DATA
+// statement so that the predicate IsInitialized(base symbol) will be true
+// during semantic analysis before the symbol's initializer is constructed.
+bool ConstructVisitor::Pre(const parser::DataIDoObject &x) {
+  std::visit(
+      common::visitors{
+          [&](const parser::Scalar<Indirection<parser::Designator>> &y) {
+            Walk(y.thing.value());
+            const parser::Name &first{parser::GetFirstName(y.thing.value())};
+            if (first.symbol) {
+              first.symbol->set(Symbol::Flag::InDataStmt);
+            }
+          },
+          [&](const Indirection<parser::DataImpliedDo> &y) { Walk(y.value()); },
+      },
+      x.u);
+  return false;
+}
+
 bool ConstructVisitor::Pre(const parser::DataStmtObject &x) {
   std::visit(common::visitors{
                  [&](const Indirection<parser::Variable> &y) {
                    Walk(y.value());
-                   if (const auto *designator{
-                           std::get_if<Indirection<parser::Designator>>(
-                               &y.value().u)}) {
-                     if (const parser::Name *
-                         name{ResolveDesignator(designator->value())}) {
-                       if (name->symbol) {
-                         name->symbol->set(Symbol::Flag::InDataStmt);
-                       }
-                     }
-                     // TODO check C874 - C881
-                   } else {
-                     // TODO report C875 error: variable is not a designator
-                     // here?
+                   const parser::Name &first{parser::GetFirstName(y.value())};
+                   if (first.symbol) {
+                     first.symbol->set(Symbol::Flag::InDataStmt);
                    }
                  },
                  [&](const parser::DataImpliedDo &y) {
                    PushScope(Scope::Kind::ImpliedDos, nullptr);
                    Walk(y);
                    PopScope();
                  },
              },
       x.u);
   return false;
 }
 
 bool ConstructVisitor::Pre(const parser::DataStmtValue &x) {
   const auto &data{std::get<parser::DataStmtConstant>(x.t)};
   auto &mutableData{const_cast<parser::DataStmtConstant &>(data)};
   if (auto *elem{parser::Unwrap<parser::ArrayElement>(mutableData)}) {
     if (const auto *name{std::get_if<parser::Name>(&elem->base.u)}) {
       if (const Symbol * symbol{FindSymbol(*name)}) {
         if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) {
           if (ultimate->has<DerivedTypeDetails>()) {
-            mutableData.u = elem->ConvertToStructureConstructor(
-                DerivedTypeSpec{name->source, *ultimate});
+            mutableData.u = parser::Constant<parser::StructureConstructor>{
+                elem->ConvertToStructureConstructor(
+                    DerivedTypeSpec{name->source, *ultimate})};
           }
         }
       }
     }
   }
   return true;
 }
 
const parser::Name *DeclarationVisitor::FindComponent(
   } else {
     SayWithDecl(
         *base, symbol, "'%s' is not an object of derived type"_err_en_US);
   }
   return nullptr;
 }
 
 // C764, C765
-void DeclarationVisitor::CheckInitialDataTarget(
+bool DeclarationVisitor::CheckInitialDataTarget(
     const Symbol &pointer, const SomeExpr &expr, SourceName source) {
-  auto &messages{GetFoldingContext().messages()};
-  auto restorer{messages.SetLocation(source)};
-  if (!evaluate::IsInitialDataTarget(expr, &messages)) {
-    Say(source,
-        "Pointer '%s' cannot be initialized with a reference to a designator with non-constant subscripts"_err_en_US,
-        pointer.name());
-    return;
-  }
-  if (pointer.Rank() != expr.Rank()) {
-    Say(source,
-        "Pointer '%s' of rank %d cannot be initialized with a target of different rank (%d)"_err_en_US,
-        pointer.name(), pointer.Rank(), expr.Rank());
-    return;
-  }
-  // TODO: check type compatibility
-  // TODO: check non-deferred type parameter values
-  // TODO: check contiguity if pointer is CONTIGUOUS
+  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 (const Symbol * targetSym{target.symbol}) {
     } 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 being declared can be available for use in the expression, e.g.:
+  //   real, parameter :: x = tiny(x)
   if (!name.symbol) {
     return;
   }
+  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 to the end of the specification parts so that forward
-    // references work better.
+    // 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.
     return;
   }
-  // Traversal of the initializer was deferred to here so that the
-  // symbol being declared can be available for use in the expression, e.g.:
-  //   real, parameter :: x = tiny(x)
-  Walk(init.u);
-  Symbol &ultimate{name.symbol->GetUltimate()};
   if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
     // TODO: check C762 - all bounds and type parameters of component
     // are colons or constant expressions if component is initialized
-    bool isPointer{false};
+    bool isNullPointer{false};
     std::visit(
         common::visitors{
             [&](const parser::ConstantExpr &expr) {
-              if (inComponentDecl) {
-                // Can't convert to type of component, which might not yet
-                // be known; that's done later during instantiation.
-                if (MaybeExpr value{EvaluateExpr(expr)}) {
-                  details->set_init(std::move(*value));
-                }
-              } else {
-                if (MaybeExpr folded{EvaluateConvertedExpr(
-                        ultimate, expr, expr.thing.value().source)}) {
-                  details->set_init(std::move(*folded));
-                }
-              }
+              NonPointerInitialization(name, expr, inComponentDecl);
             },
             [&](const parser::NullInit &) {
-              isPointer = true;
+              isNullPointer = true;
               details->set_init(SomeExpr{evaluate::NullPointer{}});
             },
-            [&](const parser::InitialDataTarget &initExpr) {
-              isPointer = true;
-              if (MaybeExpr expr{EvaluateExpr(initExpr)}) {
-                CheckInitialDataTarget(
-                    ultimate, *expr, initExpr.value().source);
-                details->set_init(std::move(*expr));
-              }
+            [&](const parser::InitialDataTarget &) {
+              DIE("InitialDataTarget can't appear here");
             },
             [&](const std::list<Indirection<parser::DataStmtValue>> &) {
+              // TODO: Need to Walk(init.u); when implementing this case
               if (inComponentDecl) {
                 Say(name,
                     "Component '%s' initialized with DATA statement values"_err_en_US);
               } else {
                 // TODO - DATA statements and DATA-like initialization extension
               }
             },
         },
         init.u);
-    if (isPointer) {
+    if (isNullPointer) {
       if (!IsPointer(ultimate)) {
         Say(name,
-            "Non-pointer component '%s' initialized with pointer target"_err_en_US);
+            "Non-pointer component '%s' initialized with null pointer"_err_en_US);
       }
-    } else {
-      if (IsPointer(ultimate)) {
-        Say(name,
-            "Object pointer component '%s' initialized with non-pointer expression"_err_en_US);
-      } else if (IsAllocatable(ultimate)) {
-        Say(name, "Allocatable component '%s' cannot be initialized"_err_en_US);
-      }
+    } else if (IsPointer(ultimate)) {
     }
   }
 }
 
 void DeclarationVisitor::PointerInitialization(
     const parser::Name &name, const parser::InitialDataTarget &target) {
   if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
if (!context().HasError(ultimate)) {
             "'%s' is not a procedure pointer but is initialized "
             "like one"_err_en_US);
         context().SetError(ultimate);
       }
     }
   }
 }
 
+void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
+    const parser::ConstantExpr &expr, bool inComponentDecl) {
+  if (name.symbol) {
+    Symbol &ultimate{name.symbol->GetUltimate()};
+    if (IsPointer(ultimate)) {
+      Say(name, "'%s' is a pointer but is not initialized like one"_err_en_US);
+    } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
+      CHECK(!details->init());
+      Walk(expr);
+      // TODO: check C762 - all bounds and type parameters of component
+      // are colons or constant expressions if component is initialized
+      if (inComponentDecl) {
+        // Can't convert to type of component, which might not yet
+        // be known; that's done later during instantiation.
+        if (MaybeExpr value{EvaluateExpr(expr)}) {
+          details->set_init(std::move(*value));
+        }
+      } else if (MaybeExpr folded{EvaluateConvertedExpr(
+                     ultimate, expr, expr.thing.value().source)}) {
+        details->set_init(std::move(*folded));
+      }
+    }
+  }
+}
+
 void ResolveNamesVisitor::HandleCall(
     Symbol::Flag procFlag, const parser::Call &call) {
   std::visit(
       common::visitors{
           [&](const parser::Name &x) { HandleProcedureName(procFlag, x); },
           [&](const parser::ProcComponentRef &x) { Walk(x); },
       },
       std::get<parser::ProcedureDesignator>(call.t).u);
for (auto &pair : currScope()) {
     auto &symbol{*pair.second};
     if (NeedsExplicitType(symbol)) {
       ApplyImplicitRules(symbol);
     }
     if (symbol.has<GenericDetails>()) {
       CheckGenericProcedures(symbol);
     }
     if (inModule && symbol.attrs().test(Attr::EXTERNAL) &&
-        !symbol.test(Symbol::Flag::Function)) {
+        !symbol.test(Symbol::Flag::Function) &&
+        !symbol.test(Symbol::Flag::Subroutine)) {
       // in a module, external proc without return type is subroutine
-      symbol.set(Symbol::Flag::Subroutine);
+      symbol.set(
+          symbol.GetType() ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
     }
   }
   currScope().InstantiateDerivedTypes(context());
   // TODO: what about instantiations in BLOCK?
   CheckSaveStmts();
   CheckCommonBlocks();
   CheckEquivalenceSets();
 }

flang/lib/Semantics/rewrite-parse-tree.cpp

 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include <list>
 
 namespace Fortran::semantics {
 
 using namespace parser::literals;
 
-/// Convert mis-identified statement functions to array element assignments.
-/// Convert mis-identified format expressions to namelist group names.
-/// Convert mis-identified character variables in I/O units to integer
+/// Convert misidentified statement functions to array element assignments.
+/// Convert misidentified format expressions to namelist group names.
+/// Convert misidentified character variables in I/O units to integer
 /// unit number expressions.
+/// Convert misidentified named constants in data statement values to
+/// initial data targets
 class RewriteMutator {
 public:
   RewriteMutator(SemanticsContext &context)
       : errorOnUnresolvedName_{!context.AnyFatalError()},
         messages_{context.messages()} {}
 
   // Default action for a parse tree node is to visit children.
   template <typename T> bool Pre(T &) { return true; }
   template <typename T> void Post(T &) {}
 
   void Post(parser::Name &);
   void Post(parser::SpecificationPart &);
   bool Pre(parser::ExecutionPart &);
   void Post(parser::IoUnit &);
   void Post(parser::ReadStmt &);
   void Post(parser::WriteStmt &);
+  void Post(parser::DataStmtConstant &);
 
   // Name resolution yet implemented:
+  // TODO: Can some/all of these now be enabled?
   bool Pre(parser::EquivalenceStmt &) { return false; }
   bool Pre(parser::Keyword &) { return false; }
   bool Pre(parser::EntryStmt &) { return false; }
   bool Pre(parser::CompilerDirective &) { return false; }
 
   // Don't bother resolving names in end statements.
   bool Pre(parser::EndBlockDataStmt &) { return false; }
   bool Pre(parser::EndFunctionStmt &) { return false; }

 void RewriteMutator::Post(parser::ReadStmt &x) {
   FixMisparsedUntaggedNamelistName(x);
 }
 
 void RewriteMutator::Post(parser::WriteStmt &x) {
   FixMisparsedUntaggedNamelistName(x);
 }
 
+void RewriteMutator::Post(parser::DataStmtConstant &x) {
+  if (auto *scalar{std::get_if<parser::Scalar<parser::ConstantValue>>(&x.u)}) {
+    if (auto *named{std::get_if<parser::NamedConstant>(&scalar->thing.u)}) {
+      if (const Symbol * symbol{named->v.symbol}) {
+        if (!IsNamedConstant(*symbol) && symbol->attrs().test(Attr::TARGET)) {
+          x.u = parser::InitialDataTarget{
+              parser::Designator{parser::DataRef{parser::Name{named->v}}}};
+        }
+      }
+    }
+  }
+}
+
 bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
   RewriteMutator mutator{context};
   parser::Walk(program, mutator);
   return !context.AnyFatalError();
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/tools.cpp

 const SomeExpr *GetExprHelper::Get(const parser::Expr &x) {
   CheckMissingAnalysis(!x.typedExpr, x);
   return common::GetPtrFromOptional(x.typedExpr->v);
 }
 const SomeExpr *GetExprHelper::Get(const parser::Variable &x) {
   CheckMissingAnalysis(!x.typedExpr, x);
   return common::GetPtrFromOptional(x.typedExpr->v);
 }
+const SomeExpr *GetExprHelper::Get(const parser::DataStmtConstant &x) {
+  CheckMissingAnalysis(!x.typedExpr, x);
+  return common::GetPtrFromOptional(x.typedExpr->v);
+}
 
 const evaluate::Assignment *GetAssignment(const parser::AssignmentStmt &x) {
   CheckMissingAnalysis(!x.typedAssignment, x);
   return common::GetPtrFromOptional(x.typedAssignment->v);
 }
 const evaluate::Assignment *GetAssignment(
     const parser::PointerAssignmentStmt &x) {
   CheckMissingAnalysis(!x.typedAssignment, x);
bool CanBeTypeBoundProc(const Symbol *symbol) {
   } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
     return !symbol->attrs().test(Attr::INTRINSIC) &&
         proc->HasExplicitInterface();
   } else {
     return false;
   }
 }
 
-bool IsInitialized(const Symbol &symbol) {
-  if (symbol.test(Symbol::Flag::InDataStmt)) {
+bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
+  if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
     return true;
   } else if (IsNamedConstant(symbol)) {
     return false;
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (IsAllocatable(symbol) || object->init()) {
+    if (object->init()) {
       return true;
-    }
-    if (!IsPointer(symbol) && object->type()) {
+    } else if (object->isDummy() || IsFunctionResult(symbol)) {
+      return false;
+    } else if (IsAllocatable(symbol)) {
+      return true;
+    } else if (!IsPointer(symbol) && object->type()) {
       if (const auto *derived{object->type()->AsDerived()}) {
         if (derived->HasDefaultInitialization()) {
           return true;
         }
       }
     }
   } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     return proc->init().has_value();
bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
   if (symbol && symbol->attrs().test(Attr::MODULE)) {
     if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
       return details->isInterface();
     }
   }
   return false;
 }
 
+// 3.11 automatic data object
+bool IsAutomatic(const Symbol &symbol) {
+  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
+      if (const DeclTypeSpec * type{symbol.GetType()}) {
+        // If a type parameter value is not a constant expression, the
+        // object is automatic.
+        if (type->category() == DeclTypeSpec::Character) {
+          if (const auto &length{
+                  type->characterTypeSpec().length().GetExplicit()}) {
+            if (!evaluate::IsConstantExpr(*length)) {
+              return true;
+            }
+          }
+        } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+          for (const auto &pair : derived->parameters()) {
+            if (const auto &value{pair.second.GetExplicit()}) {
+              if (!evaluate::IsConstantExpr(*value)) {
+                return true;
+              }
+            }
+          }
+        }
+      }
+      // If an array bound is not a constant expression, the object is
+      // automatic.
+      for (const ShapeSpec &dim : object->shape()) {
+        if (const auto &lb{dim.lbound().GetExplicit()}) {
+          if (!evaluate::IsConstantExpr(*lb)) {
+            return true;
+          }
+        }
+        if (const auto &ub{dim.ubound().GetExplicit()}) {
+          if (!evaluate::IsConstantExpr(*ub)) {
+            return true;
+          }
+        }
+      }
+    }
+  }
+  return false;
+}
+
 bool IsFinalizable(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
       return IsFinalizable(*derived);
     }
   }
   return false;
 }
if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->category() == DeclTypeSpec::Character &&
         type->characterTypeSpec().length().isAssumed();
   } else {
     return false;
   }
 }
 
 bool IsInBlankCommon(const Symbol &symbol) {
-  if (FindCommonBlockContaining(symbol)) {
-    if (const auto *details{
-            symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-      if (details->commonBlock()) {
-        if (details->commonBlock()->name().empty()) {
-          return true;
-        }
-      }
-    }
-  }
-  return false;
+  const Symbol *block{FindCommonBlockContaining(symbol)};
+  return block && block->name().empty();
 }
 
 // C722 and C723:  For a function to be assumed length, it must be external and
 // of CHARACTER type
 bool IsExternal(const Symbol &symbol) {
   return (symbol.has<SubprogramDetails>() && symbol.owner().IsGlobal()) ||
       symbol.attrs().test(Attr::EXTERNAL);
 }

flang/lib/Semantics/type.cpp

bool DerivedTypeSpec::MightBeParameterized() const {
   return !cooked_ || !parameters_.empty();
 }
 
 bool DerivedTypeSpec::IsForwardReferenced() const {
   return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();
 }
 
 bool DerivedTypeSpec::HasDefaultInitialization() const {
-  for (const Scope *scope{scope_}; scope;
-       scope = scope->GetDerivedTypeParent()) {
-    for (const auto &pair : *scope) {
-      const Symbol &symbol{*pair.second};
-      if (IsAllocatable(symbol) || IsInitialized(symbol)) {
-        return true;
-      }
-    }
-  }
-  return false;
+  DirectComponentIterator components{*this};
+  return bool{std::find_if(components.begin(), components.end(),
+      [](const Symbol &component) { return IsInitialized(component); })};
 }
 
 ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
   return const_cast<ParamValue *>(
       const_cast<const DerivedTypeSpec *>(this)->FindParameter(target));
 }
 
 class InstantiateHelper {

flang/test/Semantics/data01.f90

subroutine CheckRepeat
   real, parameter::numbers(5) = ( /-11.11,-22.22,-33.33,44.44,55.55/ )
   integer, parameter :: repeat = -1
   integer :: myAge = 2 
   type(person) myName
   !C882
   !ERROR: Missing initialization for parameter 'uninitialized'
   integer, parameter :: uninitialized
   !C882
-  !ERROR: Repeat count for data value must not be negative
+  !ERROR: Repeat count (-1) for data value must not be negative
   DATA myName%age / repeat * 35 /
   !C882
-  !ERROR: Repeat count for data value must not be negative
+  !ERROR: Repeat count (-11) for data value must not be negative
   DATA myName%age / digits(1) * 35 /
   !C882
   !ERROR: Must be a constant value
   DATA myName%age / repet * 35 /
   !C885
   !ERROR: Must have INTEGER type, but is REAL(4)
   DATA myName%age / numbers(1) * 35 /
   !C886
subroutine CheckValue
   integer :: myAge = 2
   type(person) myName
   !OK: constant structure constructor
   data myname / person(1, 'Abcd Ijkl') /
   !C883
   !ERROR: 'persn' is not an array
   data myname / persn(2, 'Abcd Efgh') /
   !C884
-  !ERROR: Structure constructor in data value must be a constant expression
+  !ERROR: Must be a constant value
   data myname / person(myAge, 'Abcd Ijkl') /
   integer, parameter :: a(5) =(/11, 22, 33, 44, 55/)
   integer :: b(5) =(/11, 22, 33, 44, 55/)
   integer :: i
   integer :: x
   !OK: constant array element
   data x / a(1) /
   !C886, C887
   !ERROR: Must be a constant value
   data x / a(i) /
   !ERROR: Must be a constant value
   data x / b(1) /
 end

flang/test/Semantics/data04.f90

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

flang/test/Semantics/entry01.f90

subroutine subr(goodarg1)
   real, intent(in) :: goodarg1
   real :: goodarg2
   !ERROR: A dummy argument may not also be a named constant
   integer, parameter :: badarg1 = 1
   type :: badarg2
   end type
   common /badarg3/ x
   namelist /badarg4/ x
+  !ERROR: A dummy argument must not be initialized
   !ERROR: A dummy argument may not have the SAVE attribute
   integer :: badarg5 = 2
   entry okargs(goodarg1, goodarg2)
   !ERROR: RESULT(br1) may appear only in a function
   entry badresult() result(br1) ! C1572
   !ERROR: ENTRY dummy argument 'badarg2' is previously declared as an item that may not be used as a dummy argument
   !ERROR: ENTRY dummy argument 'badarg4' is previously declared as an item that may not be used as a dummy argument
   entry badargs(badarg1,badarg2,badarg3,badarg4,badarg5)

flang/test/Semantics/init01.f90

 !ERROR: An initial data target may not be a reference to an ALLOCATABLE 'x1'
   real, pointer :: p1 => x1
 !ERROR: An initial data target may not be a reference to a coarray 'x2'
   real, pointer :: p2 => x2
 !ERROR: An initial data target may not be a reference to an object 'x3' that lacks the TARGET attribute
   real, pointer :: p3 => x3
 !ERROR: An initial data target may not be a reference to an object 'x4' that lacks the SAVE attribute
   real, pointer :: p4 => x4
-!ERROR: Pointer 'p5' cannot be initialized with a reference to a designator with non-constant subscripts
+!ERROR: An initial data target must be a designator with constant subscripts
   real, pointer :: p5 => x5(j)
-!ERROR: Pointer 'p6' of rank 0 cannot be initialized with a target of different rank (1)
+!ERROR: Pointer has rank 0 but target has rank 1
   real, pointer :: p6 => x5
 
 !TODO: type incompatibility, non-deferred type parameter values, contiguity
 
 end subroutine test

flang/test/Semantics/resolve30.f90

 
 subroutine s3
   implicit none
   integer :: i, j
   block
     import, none
     !ERROR: No explicit type declared for 'i'
     real :: a(16) = [(i, i=1, 16)]
+    real :: b(16)
     !ERROR: No explicit type declared for 'j'
-    data(a(j), j=1, 16) / 16 * 0.0 /
+    data(b(j), j=1, 16) / 16 * 0.0 /
   end block
 end
 
 subroutine s4
   real :: i, j
   !ERROR: Must have INTEGER type, but is REAL(4)
   real :: a(16) = [(i, i=1, 16)]
-  data(
-    !ERROR: Must have INTEGER type, but is REAL(4)
-    a(j), &
-    !ERROR: Must have INTEGER type, but is REAL(4)
-    j=1, 16 &
-  ) / 16 * 0.0 /
+  real :: b(16)
+  data(b(j), j=1, 16) / 16 * 0.0 /
 end

flang/test/Semantics/resolve40.f90

 
 subroutine s8
   data x/1.0/
   !ERROR: The type of 'x' has already been implicitly declared
   integer x
 end
 
 subroutine s9
-  real :: x(4)
+  real :: x(2,2)
   !ERROR: 'i' is already declared in this scoping unit
   data ((x(i,i),i=1,2),i=1,2)/4*0.0/
 end
 
 module m10
   integer :: x
   public :: nl
   namelist /nl/ x

flang/test/Semantics/symbol09.f90

 !DEF: /s3 (Subroutine) Subprogram
 subroutine s3
  !DEF: /s3/n PARAMETER ObjectEntity INTEGER(4)
  integer, parameter :: n = 4
  !DEF: /s3/n2 PARAMETER ObjectEntity INTEGER(4)
  !REF: /s3/n
  integer, parameter :: n2 = n*n
  !REF: /s3/n
- !DEF: /s3/x ObjectEntity REAL(4)
+ !DEF: /s3/x (InDataStmt) ObjectEntity REAL(4)
  real, dimension(n,n) :: x
  !REF: /s3/x
  !DEF: /s3/ImpliedDos1/k (Implicit) ObjectEntity INTEGER(4)
  !DEF: /s3/ImpliedDos1/j ObjectEntity INTEGER(8)
  !REF: /s3/n
  !REF: /s3/n2
  data ((x(k,j),integer(kind=8)::j=1,n),k=1,n)/n2*3.0/
 end subroutine

  !REF: /s7/one
  complex :: z = (one, -one)
 end subroutine
 
 !DEF: /s8 (Subroutine) Subprogram
 subroutine s8
  !DEF: /s8/one PARAMETER ObjectEntity REAL(4)
  real, parameter :: one = 1.0
- !DEF: /s8/y ObjectEntity REAL(4)
- !DEF: /s8/z ObjectEntity REAL(4)
+ !DEF: /s8/y (InDataStmt) ObjectEntity REAL(4)
+ !DEF: /s8/z (InDataStmt) ObjectEntity REAL(4)
  real y(10), z(10)
  !REF: /s8/y
  !DEF: /s8/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4)
  !REF: /s8/z
  !DEF: /s8/ImpliedDos2/i (Implicit) ObjectEntity INTEGER(4)
  !DEF: /s8/x (Implicit, InDataStmt) ObjectEntity REAL(4)
  !REF: /s8/one
  data (y(i),i=1,10),(z(i),i=1,10),x/21*one/
 end subroutine