[flang] Handle parameter-dependent types in PDT initializers

For parameterized derived type component initializers whose
expressions' types depend on parameter values, f18's current
scheme of analyzing the initialization expression once during
name resolution fails.  For example,

  type :: pdt(k)
    integer, kind :: k
    real :: component = real(0.0, kind=k)
  end type

To handle such cases, it is necessary to re-analyze the parse
trees of these initialization expressions once for each distinct
initialization of the type.

This patch adds code to wipe an expression parse tree of its
typed expressions, and update those of its symbol table pointers
that reference type parameters, and then re-analyze that parse
tree to generate the properly typed component initializers.

Differential Revision: https://reviews.llvm.org/D123728

Author: klausler

flang/include/flang/Common/indirection.h

@@ -154,11 +154,14 @@ template <typename A> class ForwardOwningPointer {
     return result;
   }
 
-  void Reset(A *p, void (*del)(A *)) {
+  void Reset(A *p = nullptr) {
     if (p_) {
       deleter_(p_);
     }
     p_ = p;
+  }
+  void Reset(A *p, void (*del)(A *)) {
+    Reset(p);
     deleter_ = del;
   }
 

flang/include/flang/Parser/unparse.h

@@ -27,6 +27,7 @@ class ProcedureRef;
 namespace Fortran::parser {
 
 struct Program;
+struct Expr;
 
 // A function called before each Statement is unparsed.
 using preStatementType =
@@ -43,11 +44,19 @@ struct AnalyzedObjectsAsFortran {
   std::function<void(llvm::raw_ostream &, const evaluate::ProcedureRef &)> call;
 };
 
-// Converts parsed program to out as Fortran.
-void Unparse(llvm::raw_ostream &out, const Program &program,
+// Converts parsed program (or fragment) to out as Fortran.
+template <typename A>
+void Unparse(llvm::raw_ostream &out, const A &root,
     Encoding encoding = Encoding::UTF_8, bool capitalizeKeywords = true,
     bool backslashEscapes = true, preStatementType *preStatement = nullptr,
     AnalyzedObjectsAsFortran * = nullptr);
+
+extern template void Unparse(llvm::raw_ostream &out, const Program &program,
+    Encoding encoding, bool capitalizeKeywords, bool backslashEscapes,
+    preStatementType *preStatement, AnalyzedObjectsAsFortran *);
+extern template void Unparse(llvm::raw_ostream &out, const Expr &expr,
+    Encoding encoding, bool capitalizeKeywords, bool backslashEscapes,
+    preStatementType *preStatement, AnalyzedObjectsAsFortran *);
 } // namespace Fortran::parser
 
 #endif

flang/include/flang/Semantics/expression.h

@@ -480,6 +480,12 @@ class ExprChecker {
     exprAnalyzer_.set_inWhereBody(InWhereBody());
   }
 
+  bool Pre(const parser::ComponentDefStmt &) {
+    // Already analyzed in name resolution and PDT instantiation;
+    // do not attempt to re-analyze now without type parameters.
+    return false;
+  }
+
   template <typename A> bool Pre(const parser::Scalar<A> &x) {
     exprAnalyzer_.Analyze(x);
     return false;

flang/include/flang/Semantics/symbol.h

@@ -24,6 +24,9 @@
 namespace llvm {
 class raw_ostream;
 }
+namespace Fortran::parser {
+struct Expr;
+}
 
 namespace Fortran::semantics {
 
@@ -190,6 +193,12 @@ class ObjectEntityDetails : public EntityDetails {
   MaybeExpr &init() { return init_; }
   const MaybeExpr &init() const { return init_; }
   void set_init(MaybeExpr &&expr) { init_ = std::move(expr); }
+  const parser::Expr *unanalyzedPDTComponentInit() const {
+    return unanalyzedPDTComponentInit_;
+  }
+  void set_unanalyzedPDTComponentInit(const parser::Expr *expr) {
+    unanalyzedPDTComponentInit_ = expr;
+  }
   ArraySpec &shape() { return shape_; }
   const ArraySpec &shape() const { return shape_; }
   ArraySpec &coshape() { return coshape_; }
@@ -211,6 +220,7 @@ class ObjectEntityDetails : public EntityDetails {
 
 private:
   MaybeExpr init_;
+  const parser::Expr *unanalyzedPDTComponentInit_{nullptr};
   ArraySpec shape_;
   ArraySpec coshape_;
   const Symbol *commonBlock_{nullptr}; // common block this object is in

flang/lib/Parser/unparse.cpp

@@ -2733,12 +2733,18 @@ void UnparseVisitor::Word(const char *str) {
 
 void UnparseVisitor::Word(const std::string &str) { Word(str.c_str()); }
 
-void Unparse(llvm::raw_ostream &out, const Program &program, Encoding encoding,
+template <typename A>
+void Unparse(llvm::raw_ostream &out, const A &root, Encoding encoding,
     bool capitalizeKeywords, bool backslashEscapes,
     preStatementType *preStatement, AnalyzedObjectsAsFortran *asFortran) {
   UnparseVisitor visitor{out, 1, encoding, capitalizeKeywords, backslashEscapes,
       preStatement, asFortran};
-  Walk(program, visitor);
+  Walk(root, visitor);
   visitor.Done();
 }
+
+template void Unparse<Program>(llvm::raw_ostream &, const Program &, Encoding,
+    bool, bool, preStatementType *, AnalyzedObjectsAsFortran *);
+template void Unparse<Expr>(llvm::raw_ostream &, const Expr &, Encoding, bool,
+    bool, preStatementType *, AnalyzedObjectsAsFortran *);
 } // namespace Fortran::parser

flang/lib/Semantics/expression.cpp

@@ -693,10 +693,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
   if (std::optional<int> kind{IsImpliedDo(n.source)}) {
     return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
         *kind, AsExpr(ImpliedDoIndex{n.source})));
-  } else if (context_.HasError(n)) {
-    return std::nullopt;
-  } else if (!n.symbol) {
-    SayAt(n, "Internal error: unresolved name '%s'"_err_en_US, n.source);
+  }
+  if (context_.HasError(n.symbol)) { // includes case of no symbol
     return std::nullopt;
   } else {
     const Symbol &ultimate{n.symbol->GetUltimate()};

flang/lib/Semantics/mod-file.cpp

@@ -12,6 +12,7 @@
 #include "flang/Evaluate/tools.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parsing.h"
+#include "flang/Parser/unparse.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
@@ -45,7 +46,8 @@ struct ModHeader {
 static std::optional<SourceName> GetSubmoduleParent(const parser::Program &);
 static void CollectSymbols(const Scope &, SymbolVector &, SymbolVector &);
 static void PutPassName(llvm::raw_ostream &, const std::optional<SourceName> &);
-static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &);
+static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &,
+    const parser::Expr *);
 static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &);
 static void PutBound(llvm::raw_ostream &, const Bound &);
 static void PutShapeSpec(llvm::raw_ostream &, const ShapeSpec &);
@@ -399,7 +401,7 @@ void ModFileWriter::PutDECStructure(
         }
         decls_ << ref->name();
         PutShape(decls_, object->shape(), '(', ')');
-        PutInit(decls_, *ref, object->init());
+        PutInit(decls_, *ref, object->init(), nullptr);
         emittedDECFields_.insert(*ref);
       } else if (any) {
         break; // any later use of this structure will use RECORD/str/
@@ -661,7 +663,7 @@ void ModFileWriter::PutObjectEntity(
       symbol.attrs());
   PutShape(os, details.shape(), '(', ')');
   PutShape(os, details.coshape(), '[', ']');
-  PutInit(os, symbol, details.init());
+  PutInit(os, symbol, details.init(), details.unanalyzedPDTComponentInit());
   os << '\n';
 }
 
@@ -715,13 +717,14 @@ void ModFileWriter::PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) {
   os << '\n';
 }
 
-void PutInit(
-    llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init) {
-  if (init) {
-    if (symbol.attrs().test(Attr::PARAMETER) ||
-        symbol.owner().IsDerivedType()) {
-      os << (symbol.attrs().test(Attr::POINTER) ? "=>" : "=");
-      init->AsFortran(os);
+void PutInit(llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init,
+    const parser::Expr *unanalyzed) {
+  if (symbol.attrs().test(Attr::PARAMETER) || symbol.owner().IsDerivedType()) {
+    const char *assign{symbol.attrs().test(Attr::POINTER) ? "=>" : "="};
+    if (unanalyzed) {
+      parser::Unparse(os << assign, *unanalyzed);
+    } else if (init) {
+      init->AsFortran(os << assign);
     }
   }
 }

flang/lib/Semantics/resolve-names.cpp

@@ -6599,14 +6599,13 @@ void DeclarationVisitor::NonPointerInitialization(
         CHECK(!details->init());
         Walk(expr);
         if (ultimate.owner().IsParameterizedDerivedType()) {
-          // Can't convert to type of component, which might not yet
-          // be known; that's done later during PDT instantiation.
-          if (MaybeExpr value{EvaluateExpr(expr)}) {
-            details->set_init(std::move(*value));
+          // Save the expression for per-instantiation analysis.
+          details->set_unanalyzedPDTComponentInit(&expr.thing.value());
+        } else {
+          if (MaybeExpr folded{EvaluateNonPointerInitializer(
+                  ultimate, expr, expr.thing.value().source)}) {
+            details->set_init(std::move(*folded));
           }
-        } else if (MaybeExpr folded{EvaluateNonPointerInitializer(
-                       ultimate, expr, expr.thing.value().source)}) {
-          details->set_init(std::move(*folded));
         }
       }
     }

flang/lib/Semantics/symbol.cpp

@@ -380,6 +380,9 @@ llvm::raw_ostream &operator<<(
   DumpList(os, "shape", x.shape());
   DumpList(os, "coshape", x.coshape());
   DumpExpr(os, "init", x.init_);
+  if (x.unanalyzedPDTComponentInit()) {
+    os << " (has unanalyzedPDTComponentInit)";
+  }
   return os;
 }
 

flang/lib/Semantics/type.cpp

@@ -12,6 +12,7 @@
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Parser/characters.h"
+#include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
@@ -378,6 +379,31 @@ void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
   ComputeOffsets(context(), scope_);
 }
 
+// Walks a parsed expression to prepare it for (re)analysis;
+// clears out the typedExpr analysis results and re-resolves
+// symbol table pointers of type parameters.
+class ComponentInitResetHelper {
+public:
+  explicit ComponentInitResetHelper(Scope &scope) : scope_{scope} {}
+
+  template <typename A> bool Pre(const A &) { return true; }
+
+  template <typename A> void Post(const A &x) {
+    if constexpr (parser::HasTypedExpr<A>()) {
+      x.typedExpr.Reset();
+    }
+  }
+
+  void Post(const parser::Name &name) {
+    if (name.symbol && name.symbol->has<TypeParamDetails>()) {
+      name.symbol = scope_.FindSymbol(name.source);
+    }
+  }
+
+private:
+  Scope &scope_;
+};
+
 void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
   auto pair{scope_.try_emplace(
       oldSymbol.name(), oldSymbol.attrs(), common::Clone(oldSymbol.details()))};
@@ -409,6 +435,18 @@ void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
         dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));
       }
     }
+    if (const auto *parsedExpr{details->unanalyzedPDTComponentInit()}) {
+      // Analyze the parsed expression in this PDT instantiation context.
+      ComponentInitResetHelper resetter{scope_};
+      parser::Walk(*parsedExpr, resetter);
+      auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
+      details->set_init(evaluate::Fold(
+          foldingContext(), AnalyzeExpr(context(), *parsedExpr)));
+      details->set_unanalyzedPDTComponentInit(nullptr);
+      // Remove analysis results to prevent unparsing or other use of
+      // instantiation-specific expressions.
+      parser::Walk(*parsedExpr, resetter);
+    }
     if (MaybeExpr & init{details->init()}) {
       // Non-pointer components with default initializers are
       // processed now so that those default initializers can be used

flang/test/Semantics/init01.f90

@@ -46,7 +46,8 @@ subroutine dataobjects(j)
   real :: x10(2,3) = reshape([real::(k,k=1,6)], [3, 2])
 end subroutine
 
-subroutine components
+subroutine components(n)
+  integer, intent(in) :: n
   real, target, save :: a1(3)
   real, target :: a2
   real, save :: a3
@@ -64,7 +65,7 @@ subroutine components
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x2(kind) = [1., 2., 3.]
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
-!ERROR: An automatic variable or component must not be initialized
+!ERROR: Shape of initialized object 'x3' must be constant
     real :: x3(len) = [1., 2., 3.]
     real, pointer :: p1(:) => a1
 !ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
@@ -80,8 +81,8 @@ subroutine components
 !ERROR: Pointer has rank 1 but target has rank 0
     real, pointer :: p5(:) => a4
   end type
-  type(t2(3,3)) :: o1
-  type(t2(2,2)) :: o2
+  type(t2(3,2)) :: o1
+  type(t2(2,n)) :: o2
   type :: t3
     real :: x
   end type

flang/test/Semantics/modfile48.f90

@@ -0,0 +1,18 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+! Ensure proper formatting of component initializers in PDTs;
+! they should be unparsed from their parse trees.
+module m
+  type :: t(k)
+    integer, kind :: k
+    real(kind=k) :: x = real(0., kind=k)
+  end type
+end module
+
+!Expect: m.mod
+!module m
+!type::t(k)
+!integer(4),kind::k
+!real(int(int(k,kind=4),kind=8))::x=real(0., kind=k)
+!end type
+!intrinsic::real
+!end

flang/test/Semantics/structconst02.f90

@@ -11,10 +11,10 @@ end function realfunc
   type :: scalar(ik,rk,zk,ck,lk,len)
     integer, kind :: ik = 4, rk = 4, zk = 4, ck = 1, lk = 1
     integer, len :: len = 1
-    integer(kind=ik) :: ix = 0
-    real(kind=rk) :: rx = 0.
-    complex(kind=zk) :: zx = (0.,0.)
-    !ERROR: An automatic variable or component must not be initialized
+    integer(kind=ik) :: ix = int(0,kind=ik)
+    real(kind=rk) :: rx = real(0.,kind=rk)
+    complex(kind=zk) :: zx = cmplx(0.,0.,kind=zk)
+    !ERROR: Initialization expression for 'cx' (%SET_LENGTH(" ",len)) cannot be computed as a constant value
     character(kind=ck,len=len) :: cx = ' '
     logical(kind=lk) :: lx = .false.
     real(kind=rk), pointer :: rp => NULL()
@@ -25,7 +25,11 @@ end function realfunc
   subroutine scalararg(x)
     type(scalar), intent(in) :: x
   end subroutine scalararg
-  subroutine errors
+  subroutine errors(n)
+    integer, intent(in) :: n
+    call scalararg(scalar(4)()) ! ok
+    !ERROR: Structure constructor lacks a value for component 'cx'
+    call scalararg(scalar(len=n)()) ! triggers error on 'cx'
     call scalararg(scalar(4)(ix=1,rx=2.,zx=(3.,4.),cx='a',lx=.true.))
     call scalararg(scalar(4)(1,2.,(3.,4.),'a',.true.))
 !    call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true._4))