diff --git a/flang/include/flang/Common/indirection.h b/flang/include/flang/Common/indirection.h --- a/flang/include/flang/Common/indirection.h +++ b/flang/include/flang/Common/indirection.h @@ -154,11 +154,14 @@ 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; } diff --git a/flang/include/flang/Parser/unparse.h b/flang/include/flang/Parser/unparse.h --- a/flang/include/flang/Parser/unparse.h +++ b/flang/include/flang/Parser/unparse.h @@ -27,6 +27,7 @@ namespace Fortran::parser { struct Program; +struct Expr; // A function called before each Statement is unparsed. using preStatementType = @@ -43,11 +44,19 @@ std::function 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 +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 diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -480,6 +480,12 @@ 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 bool Pre(const parser::Scalar &x) { exprAnalyzer_.Analyze(x); return false; diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/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 @@ 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 @@ private: MaybeExpr init_; + const parser::Expr *unanalyzedPDTComponentInit_{nullptr}; ArraySpec shape_; ArraySpec coshape_; const Symbol *commonBlock_{nullptr}; // common block this object is in diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -2733,12 +2733,18 @@ void UnparseVisitor::Word(const std::string &str) { Word(str.c_str()); } -void Unparse(llvm::raw_ostream &out, const Program &program, Encoding encoding, +template +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(llvm::raw_ostream &, const Program &, Encoding, + bool, bool, preStatementType *, AnalyzedObjectsAsFortran *); +template void Unparse(llvm::raw_ostream &, const Expr &, Encoding, bool, + bool, preStatementType *, AnalyzedObjectsAsFortran *); } // namespace Fortran::parser diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -693,10 +693,8 @@ if (std::optional kind{IsImpliedDo(n.source)}) { return AsMaybeExpr(ConvertToKind( *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()}; diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp --- a/flang/lib/Semantics/mod-file.cpp +++ b/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 @@ static std::optional GetSubmoduleParent(const parser::Program &); static void CollectSymbols(const Scope &, SymbolVector &, SymbolVector &); static void PutPassName(llvm::raw_ostream &, const std::optional &); -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 @@ } 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 @@ 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 @@ 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); } } } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -6599,14 +6599,13 @@ 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)); } } } diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -380,6 +380,9 @@ DumpList(os, "shape", x.shape()); DumpList(os, "coshape", x.coshape()); DumpExpr(os, "init", x.init_); + if (x.unanalyzedPDTComponentInit()) { + os << " (has unanalyzedPDTComponentInit)"; + } return os; } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/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 @@ 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 bool Pre(const A &) { return true; } + + template void Post(const A &x) { + if constexpr (parser::HasTypedExpr()) { + x.typedExpr.Reset(); + } + } + + void Post(const parser::Name &name) { + if (name.symbol && name.symbol->has()) { + 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 @@ 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 diff --git a/flang/test/Semantics/init01.f90 b/flang/test/Semantics/init01.f90 --- a/flang/test/Semantics/init01.f90 +++ b/flang/test/Semantics/init01.f90 @@ -46,7 +46,8 @@ 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 @@ !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 @@ !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 diff --git a/flang/test/Semantics/modfile48.f90 b/flang/test/Semantics/modfile48.f90 new file mode 100644 --- /dev/null +++ b/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 diff --git a/flang/test/Semantics/structconst02.f90 b/flang/test/Semantics/structconst02.f90 --- a/flang/test/Semantics/structconst02.f90 +++ b/flang/test/Semantics/structconst02.f90 @@ -11,10 +11,10 @@ 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 @@ 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))