From c14cf92b5a1cb13a33786291604c24a42e51b8eb Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Fri, 17 Dec 2021 16:48:16 -0800 Subject: [PATCH] [flang] Implement semantics for DEC STRUCTURE/RECORD Implements part of the legacy "DEC structures" feature from VMS Fortran. STRUCTUREs are processed as if they were derived types with SEQUENCE. DATA-like object entity initialization is supported as well (e.g., INTEGER FOO/666/) since it was used for default component initialization in structures. Anonymous components (named %FILL) are also supported. These features, and UNION/MAP, were already being parsed. An omission in the collection of structure field names in the case of nested structures with entity declarations was fixed in the parser. Structures are supported in modules, but this is mostly for testing purposes. The names of fields in structures accessed via USE association cannot appear with dot notation in client code (at least not yet). DEC structures antedate Fortran 90, so their actual use in applications should not involve modules. This patch does not implement UNION/MAP, since that feature would impose difficulties later in lowering them to MLIR types. In the meantime, if they appear, semantics will issue a "not yet implemented" error message. Differential Revision: https://reviews.llvm.org/D117151 --- flang/docs/Extensions.md | 4 +- flang/include/flang/Common/unwrap.h | 2 +- flang/include/flang/Parser/dump-parse-tree.h | 2 + flang/include/flang/Parser/parse-tree.h | 17 +- flang/include/flang/Parser/tools.h | 2 +- flang/include/flang/Parser/user-state.h | 5 + flang/include/flang/Semantics/expression.h | 4 +- flang/include/flang/Semantics/semantics.h | 1 + flang/include/flang/Semantics/symbol.h | 7 +- flang/lib/Evaluate/fold-designator.cpp | 34 ++-- flang/lib/Parser/Fortran-parsers.cpp | 33 +++- flang/lib/Parser/unparse.cpp | 46 +++-- flang/lib/Parser/user-state.cpp | 23 ++- flang/lib/Semantics/check-data.cpp | 23 +++ flang/lib/Semantics/check-data.h | 4 + flang/lib/Semantics/data-to-inits.cpp | 89 +++++++--- flang/lib/Semantics/data-to-inits.h | 6 + flang/lib/Semantics/mod-file.cpp | 126 ++++++++++++-- flang/lib/Semantics/mod-file.h | 15 +- flang/lib/Semantics/resolve-names.cpp | 171 ++++++++++++++----- flang/lib/Semantics/runtime-type-info.cpp | 5 +- flang/lib/Semantics/semantics.cpp | 6 +- flang/lib/Semantics/type.cpp | 9 +- flang/test/Semantics/modfile42.f90 | 48 ++++++ flang/test/Semantics/struct01.f90 | 19 +++ flang/test/Semantics/symbol15.f90 | 24 +-- 26 files changed, 566 insertions(+), 159 deletions(-) create mode 100644 flang/test/Semantics/modfile42.f90 create mode 100644 flang/test/Semantics/struct01.f90 diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 7bcea54b0f52..e01c4d7ef37b 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -81,7 +81,9 @@ end * Kind specification with `*`, e.g. `REAL*4` * `DOUBLE COMPLEX` * Signed complex literal constants -* DEC `STRUCTURE`, `RECORD`, `UNION`, and `MAP` +* DEC `STRUCTURE`, `RECORD`, with '%FILL'; but `UNION`, and `MAP` + are not yet supported throughout compilation, and elicit a + "not yet implemented" message. * Structure field access with `.field` * `BYTE` as synonym for `INTEGER(KIND=1)` * Quad precision REAL literals with `Q` diff --git a/flang/include/flang/Common/unwrap.h b/flang/include/flang/Common/unwrap.h index 339b6a77edc0..b6ea4a154609 100644 --- a/flang/include/flang/Common/unwrap.h +++ b/flang/include/flang/Common/unwrap.h @@ -128,7 +128,7 @@ struct UnwrapperHelper { template static auto Unwrap(const Indirection &p) -> Constify * { - return Unwrap(*p); + return Unwrap(p.value()); } template diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h index 150b011ad8ba..cf85194c0d0f 100644 --- a/flang/include/flang/Parser/dump-parse-tree.h +++ b/flang/include/flang/Parser/dump-parse-tree.h @@ -195,6 +195,8 @@ public: NODE(parser, ComponentAttrSpec) NODE(parser, ComponentDataSource) NODE(parser, ComponentDecl) + NODE(parser, FillDecl) + NODE(parser, ComponentOrFill) NODE(parser, ComponentDefStmt) NODE(parser, ComponentSpec) NODE(parser, ComputedGotoStmt) diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index 6820a874483d..f0a97402204e 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -998,13 +998,26 @@ struct ComponentDecl { t; }; +// A %FILL component for a DEC STRUCTURE. The name will be replaced +// with a distinct compiler-generated name. +struct FillDecl { + TUPLE_CLASS_BOILERPLATE(FillDecl); + std::tuple, std::optional> + t; +}; + +struct ComponentOrFill { + UNION_CLASS_BOILERPLATE(ComponentOrFill); + std::variant u; +}; + // R737 data-component-def-stmt -> // declaration-type-spec [[, component-attr-spec-list] ::] // component-decl-list struct DataComponentDefStmt { TUPLE_CLASS_BOILERPLATE(DataComponentDefStmt); std::tuple, - std::list> + std::list> t; }; @@ -3258,7 +3271,7 @@ struct Union { struct StructureStmt { TUPLE_CLASS_BOILERPLATE(StructureStmt); - std::tuple> t; + std::tuple, std::list> t; }; struct StructureDef { diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h index ccd49d2a790e..0261d8f0cf48 100644 --- a/flang/include/flang/Parser/tools.h +++ b/flang/include/flang/Parser/tools.h @@ -29,7 +29,7 @@ const Name &GetLastName(const Variable &); const Name &GetLastName(const AllocateObject &); // GetFirstName() isolates and returns a reference to the leftmost Name -// in a variable. +// in a variable or entity declaration. const Name &GetFirstName(const Name &); const Name &GetFirstName(const StructureComponent &); const Name &GetFirstName(const DataRef &); diff --git a/flang/include/flang/Parser/user-state.h b/flang/include/flang/Parser/user-state.h index 6a4cf9736f1f..61745a833c71 100644 --- a/flang/include/flang/Parser/user-state.h +++ b/flang/include/flang/Parser/user-state.h @@ -140,5 +140,10 @@ struct StructureComponents { using resultType = DataComponentDefStmt; static std::optional Parse(ParseState &); }; + +struct NestedStructureStmt { + using resultType = StructureStmt; + static std::optional Parse(ParseState &); +}; } // namespace Fortran::parser #endif // FORTRAN_PARSER_USER_STATE_H_ diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 203a88937728..fd649308d7d6 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -247,6 +247,9 @@ public: const Assignment *Analyze(const parser::AssignmentStmt &); const Assignment *Analyze(const parser::PointerAssignmentStmt &); + // Builds a typed Designator from an untyped DataRef + MaybeExpr Designate(DataRef &&); + protected: int IntegerTypeSpecKind(const parser::IntegerTypeSpec &); @@ -319,7 +322,6 @@ private: const std::list &); std::optional CreateComponent( DataRef &&, const Symbol &, const semantics::Scope &); - MaybeExpr Designate(DataRef &&); MaybeExpr CompleteSubscripts(ArrayRef &&); MaybeExpr ApplySubscripts(DataRef &&, std::vector &&); MaybeExpr TopLevelChecks(DataRef &&); diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h index 07498c46bc43..078c8a026e74 100644 --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -173,6 +173,7 @@ public: SymbolVector GetIndexVars(IndexVarKind); SourceName SaveTempName(std::string &&); SourceName GetTempName(const Scope &); + static bool IsTempName(const std::string &); // Locate and process the contents of a built-in module on demand Scope *GetBuiltinModule(const char *name); diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index b124f0382832..361d69e84921 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -255,6 +255,7 @@ public: const std::list ¶mNames() const { return paramNames_; } const SymbolVector ¶mDecls() const { return paramDecls_; } bool sequence() const { return sequence_; } + bool isDECStructure() const { return isDECStructure_; } std::map &finals() { return finals_; } const std::map &finals() const { return finals_; } bool isForwardReferenced() const { return isForwardReferenced_; } @@ -262,6 +263,7 @@ public: void add_paramDecl(const Symbol &symbol) { paramDecls_.push_back(symbol); } void add_component(const Symbol &); void set_sequence(bool x = true) { sequence_ = x; } + void set_isDECStructure(bool x = true) { isDECStructure_ = x; } void set_isForwardReferenced(bool value) { isForwardReferenced_ = value; } const std::list &componentNames() const { return componentNames_; @@ -292,6 +294,7 @@ private: std::list componentNames_; std::map finals_; // FINAL :: subr bool sequence_{false}; + bool isDECStructure_{false}; bool isForwardReferenced_{false}; friend llvm::raw_ostream &operator<<( llvm::raw_ostream &, const DerivedTypeDetails &); @@ -495,8 +498,8 @@ public: LocalityLocal, // named in LOCAL locality-spec LocalityLocalInit, // named in LOCAL_INIT locality-spec LocalityShared, // named in SHARED locality-spec - InDataStmt, // initialized in a DATA statement - InNamelist, // flag is set if the symbol is in Namelist statement + InDataStmt, // initialized in a DATA statement, =>object, or /init/ + InNamelist, // in a Namelist group CompilerCreated, // OpenACC data-sharing attribute AccPrivate, AccFirstPrivate, AccShared, diff --git a/flang/lib/Evaluate/fold-designator.cpp b/flang/lib/Evaluate/fold-designator.cpp index c4f072e1c4b2..45ae691d4b84 100644 --- a/flang/lib/Evaluate/fold-designator.cpp +++ b/flang/lib/Evaluate/fold-designator.cpp @@ -15,7 +15,7 @@ DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(OffsetSymbol) std::optional DesignatorFolder::FoldDesignator( const Symbol &symbol, ConstantSubscript which) { - if (semantics::IsPointer(symbol) || semantics::IsAllocatable(symbol)) { + if (IsAllocatableOrPointer(symbol)) { // A pointer may appear as a DATA statement object if it is the // rightmost symbol in a designator and has no subscripts. // An allocatable may appear if its initializer is NULL(). @@ -31,21 +31,11 @@ std::optional DesignatorFolder::FoldDesignator( if (auto bytes{ToInt64( type->MeasureSizeInBytes(context_, GetRank(*extents) > 0))}) { OffsetSymbol result{symbol, static_cast(*bytes)}; - auto stride{*bytes}; - for (auto extent : *extents) { - if (extent == 0) { - return std::nullopt; - } - auto quotient{which / extent}; - auto remainder{which - extent * quotient}; - result.Augment(stride * remainder); - which = quotient; - stride *= extent; - } - if (which > 0) { - isEmpty_ = true; + if (which < GetSize(*extents)) { + result.Augment(*bytes * which); + return result; } else { - return std::move(result); + isEmpty_ = true; } } } @@ -147,18 +137,18 @@ std::optional DesignatorFolder::FoldDesignator( const Component &component, ConstantSubscript which) { const Symbol &comp{component.GetLastSymbol()}; const DataRef &base{component.base()}; - std::optional result, baseResult; + std::optional baseResult, compResult; if (base.Rank() == 0) { // A%X(:) - apply "which" to component baseResult = FoldDesignator(base, 0); - result = FoldDesignator(comp, which); + compResult = FoldDesignator(comp, which); } else { // A(:)%X - apply "which" to base baseResult = FoldDesignator(base, which); - result = FoldDesignator(comp, 0); + compResult = FoldDesignator(comp, 0); } - if (result && baseResult) { - result->set_symbol(baseResult->symbol()); - result->Augment(baseResult->offset() + comp.offset()); - return result; + if (baseResult && compResult) { + OffsetSymbol result{baseResult->symbol(), compResult->size()}; + result.Augment(baseResult->offset() + compResult->offset() + comp.offset()); + return {std::move(result)}; } else { return std::nullopt; } diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp index de59b26d5815..a7d57954c6f7 100644 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -179,8 +179,11 @@ TYPE_CONTEXT_PARSER("declaration type spec"_en_US, construct())) || extension( construct( + // As is also done for the STRUCTURE statement, the name of + // the structure includes the surrounding slashes to avoid + // name clashes. construct( - "RECORD /" >> name / "/")))) + "RECORD" >> sourced("/" >> name / "/"))))) // R704 intrinsic-type-spec -> // integer-type-spec | REAL [kind-selector] | DOUBLE PRECISION | @@ -401,8 +404,8 @@ TYPE_PARSER(recovery( // N.B. The standard requires double colons if there's an initializer. TYPE_PARSER(construct(declarationTypeSpec, optionalListBeforeColons(Parser{}), - nonemptyList( - "expected component declarations"_err_en_US, Parser{}))) + nonemptyList("expected component declarations"_err_en_US, + Parser{}))) // R738 component-attr-spec -> // access-spec | ALLOCATABLE | @@ -426,6 +429,13 @@ TYPE_PARSER(construct(accessSpec) || TYPE_CONTEXT_PARSER("component declaration"_en_US, construct(name, maybe(Parser{}), maybe(coarraySpec), maybe("*" >> charLength), maybe(initialization))) +// The source field of the Name will be replaced with a distinct generated name. +TYPE_CONTEXT_PARSER("%FILL item"_en_US, + extension( + construct(space >> sourced("%FILL" >> construct()), + maybe(Parser{}), maybe("*" >> charLength)))) +TYPE_PARSER(construct(Parser{}) || + construct(Parser{})) // R740 component-array-spec -> // explicit-shape-spec-list | deferred-shape-spec-list @@ -1180,14 +1190,21 @@ TYPE_PARSER(extension(construct( construct("(" >> objectName / ",", objectName, maybe(Parser{}) / ")"))))) -TYPE_PARSER(construct("STRUCTURE /" >> name / "/", pure(true), - optionalList(entityDecl)) || - construct( - "STRUCTURE" >> name, pure(false), pure>())) +// Subtle: the name includes the surrounding slashes, which avoids +// clashes with other uses of the name in the same scope. +TYPE_PARSER(construct( + "STRUCTURE" >> maybe(sourced("/" >> name / "/")), optionalList(entityDecl))) + +constexpr auto nestedStructureDef{ + CONTEXT_PARSER("nested STRUCTURE definition"_en_US, + construct(statement(NestedStructureStmt{}), + many(Parser{}), + statement(construct( + "END STRUCTURE"_tok))))}; TYPE_PARSER(construct(statement(StructureComponents{})) || construct(indirect(Parser{})) || - construct(indirect(Parser{}))) + construct(indirect(nestedStructureDef))) TYPE_CONTEXT_PARSER("STRUCTURE definition"_en_US, extension(construct( diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp index 075719926e85..39343dfe2495 100644 --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -265,18 +265,25 @@ public: void Unparse(const DataComponentDefStmt &x) { // R737 const auto &dts{std::get(x.t)}; const auto &attrs{std::get>(x.t)}; - const auto &decls{std::get>(x.t)}; + const auto &decls{std::get>(x.t)}; Walk(dts), Walk(", ", attrs, ", "); if (!attrs.empty() || (!std::holds_alternative(dts.u) && std::none_of( - decls.begin(), decls.end(), [](const ComponentDecl &d) { - const auto &init{ - std::get>(d.t)}; - return init && - std::holds_alternative< - std::list>>( - init->u); + decls.begin(), decls.end(), [](const ComponentOrFill &c) { + return std::visit( + common::visitors{ + [](const ComponentDecl &d) { + const auto &init{ + std::get>(d.t)}; + return init && + std::holds_alternative>>( + init->u); + }, + [](const FillDecl &) { return false; }, + }, + c.u); }))) { Put(" ::"); } @@ -310,6 +317,11 @@ public: Walk("*", std::get>(x.t)); Walk(std::get>(x.t)); } + void Unparse(const FillDecl &x) { // DEC extension + Put("%FILL"); + Walk("(", std::get>(x.t), ")"); + Walk("*", std::get>(x.t)); + } void Unparse(const ComponentArraySpec &x) { // R740 std::visit(common::visitors{ [&](const std::list &y) { Walk(y, ","); }, @@ -2486,21 +2498,19 @@ public: void Unparse(const BasedPointerStmt &x) { Walk("POINTER ", x.v, ","); } void Post(const StructureField &x) { if (const auto *def{std::get_if>(&x.u)}) { - for (const auto &decl : - std::get>(def->statement.t)) { - structureComponents_.insert(std::get(decl.t).source); + for (const auto &item : + std::get>(def->statement.t)) { + if (const auto *comp{std::get_if(&item.u)}) { + structureComponents_.insert(std::get(comp->t).source); + } } } } void Unparse(const StructureStmt &x) { Word("STRUCTURE "); - if (std::get(x.t)) { // slashes around name - Put('/'), Walk(std::get(x.t)), Put('/'); - Walk(" ", std::get>(x.t), ", "); - } else { - CHECK(std::get>(x.t).empty()); - Walk(std::get(x.t)); - } + // The name, if present, includes the /slashes/ + Walk(std::get>(x.t)); + Walk(" ", std::get>(x.t), ", "); Indent(); } void Post(const Union::UnionStmt &) { Word("UNION"), Indent(); } diff --git a/flang/lib/Parser/user-state.cpp b/flang/lib/Parser/user-state.cpp index f0bc36cb6bdc..6423b6a51f28 100644 --- a/flang/lib/Parser/user-state.cpp +++ b/flang/lib/Parser/user-state.cpp @@ -63,6 +63,11 @@ std::optional LeaveDoConstruct::Parse(ParseState &state) { return {Success{}}; } +// These special parsers for bits of DEC STRUCTURE capture the names of +// their components and nested structures in the user state so that +// references to these fields with periods can be recognized as special +// cases. + std::optional OldStructureComponentName::Parse(ParseState &state) { if (std::optional n{name.Parse(state)}) { if (const auto *ustate{state.userState()}) { @@ -80,11 +85,25 @@ std::optional StructureComponents::Parse( std::optional defs{stmt.Parse(state)}; if (defs) { if (auto *ustate{state.userState()}) { - for (const auto &decl : std::get>(defs->t)) { - ustate->NoteOldStructureComponent(std::get(decl.t).source); + for (const auto &item : std::get>(defs->t)) { + if (const auto *decl{std::get_if(&item.u)}) { + ustate->NoteOldStructureComponent(std::get(decl->t).source); + } } } } return defs; } + +std::optional NestedStructureStmt::Parse(ParseState &state) { + std::optional stmt{Parser{}.Parse(state)}; + if (stmt) { + if (auto *ustate{state.userState()}) { + for (const auto &entity : std::get>(stmt->t)) { + ustate->NoteOldStructureComponent(std::get(entity.t).source); + } + } + } + return stmt; +} } // namespace Fortran::parser diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp index 338bd91f1da0..bd8d836cf352 100644 --- a/flang/lib/Semantics/check-data.cpp +++ b/flang/lib/Semantics/check-data.cpp @@ -220,6 +220,29 @@ void DataChecker::Leave(const parser::DataStmtSet &set) { currentSetHasFatalErrors_ = false; } +// Handle legacy DATA-style initialization, e.g. REAL PI/3.14159/, for +// variables and components (esp. for DEC STRUCTUREs) +template void DataChecker::LegacyDataInit(const A &decl) { + if (const auto &init{ + std::get>(decl.t)}) { + const Symbol *name{std::get(decl.t).symbol}; + const auto *list{ + std::get_if>>( + &init->u)}; + if (name && list) { + AccumulateDataInitializations(inits_, exprAnalyzer_, *name, *list); + } + } +} + +void DataChecker::Leave(const parser::ComponentDecl &decl) { + LegacyDataInit(decl); +} + +void DataChecker::Leave(const parser::EntityDecl &decl) { + LegacyDataInit(decl); +} + void DataChecker::CompileDataInitializationsIntoInitializers() { ConvertToInitializers(inits_, exprAnalyzer_); } diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h index eafecd902cb9..479d32568fa6 100644 --- a/flang/lib/Semantics/check-data.h +++ b/flang/lib/Semantics/check-data.h @@ -37,6 +37,9 @@ public: void Enter(const parser::DataImpliedDo &); void Leave(const parser::DataImpliedDo &); void Leave(const parser::DataStmtSet &); + // These cases are for legacy DATA-like /initializations/ + void Leave(const parser::ComponentDecl &); + void Leave(const parser::EntityDecl &); // After all DATA statements have been processed, converts their // initializations into per-symbol static initializers. @@ -47,6 +50,7 @@ private: template void CheckIfConstantSubscript(const T &); void CheckSubscript(const parser::SectionSubscript &); bool CheckAllSubscriptsInDataRef(const parser::DataRef &, parser::CharBlock); + template void LegacyDataInit(const A &); DataInitializations inits_; evaluate::ExpressionAnalyzer exprAnalyzer_; diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp index 4f540f3f9644..be8541efda5d 100644 --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -34,11 +34,10 @@ namespace Fortran::semantics { // Steps through a list of values in a DATA statement set; implements // repetition. -class ValueListIterator { +template class ValueListIterator { public: - explicit ValueListIterator(const parser::DataStmtSet &set) - : end_{std::get>(set.t).end()}, - at_{std::get>(set.t).begin()} { + explicit ValueListIterator(const std::list &list) + : end_{list.end()}, at_{list.begin()} { SetRepetitionCount(); } bool hasFatalError() const { return hasFatalError_; } @@ -56,25 +55,27 @@ public: } private: - using listIterator = std::list::const_iterator; + using listIterator = typename std::list::const_iterator; void SetRepetitionCount(); + const parser::DataStmtValue &GetValue() const { + return DEREF(common::Unwrap(*at_)); + } const parser::DataStmtConstant &GetConstant() const { - return std::get(at_->t); + return std::get(GetValue().t); } - listIterator end_; - listIterator at_; + listIterator end_, at_; ConstantSubscript repetitionsRemaining_{0}; bool hasFatalError_{false}; }; -void ValueListIterator::SetRepetitionCount() { +template void ValueListIterator::SetRepetitionCount() { for (repetitionsRemaining_ = 1; at_ != end_; ++at_) { - if (at_->repetitions < 0) { + auto repetitions{GetValue().repetitions}; + if (repetitions < 0) { hasFatalError_ = true; - } - if (at_->repetitions > 0) { - repetitionsRemaining_ = at_->repetitions - 1; + } else if (repetitions > 0) { + repetitionsRemaining_ = repetitions - 1; return; } } @@ -86,15 +87,18 @@ void ValueListIterator::SetRepetitionCount() { // Expands the implied DO loops and array references. // Applies checks that validate each distinct elemental initialization // of the variables in a data-stmt-set, as well as those that apply -// to the corresponding values being use to initialize each element. +// to the corresponding values being used to initialize each element. +template class DataInitializationCompiler { public: DataInitializationCompiler(DataInitializations &inits, - evaluate::ExpressionAnalyzer &a, const parser::DataStmtSet &set) - : inits_{inits}, exprAnalyzer_{a}, values_{set} {} + evaluate::ExpressionAnalyzer &a, const std::list &list) + : inits_{inits}, exprAnalyzer_{a}, values_{list} {} const DataInitializations &inits() const { return inits_; } bool HasSurplusValues() const { return !values_.IsAtEnd(); } bool Scan(const parser::DataStmtObject &); + // Initializes all elements of whole variable or component + bool Scan(const Symbol &); private: bool Scan(const parser::Variable &); @@ -104,7 +108,7 @@ private: // Initializes all elements of a designator, which can be an array or section. bool InitDesignator(const SomeExpr &); - // Initializes a single object. + // Initializes a single scalar object. bool InitElement(const evaluate::OffsetSymbol &, const SomeExpr &designator); // If the returned flag is true, emit a warning about CHARACTER misusage. std::optional> ConvertElement( @@ -112,10 +116,12 @@ private: DataInitializations &inits_; evaluate::ExpressionAnalyzer &exprAnalyzer_; - ValueListIterator values_; + ValueListIterator values_; }; -bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) { +template +bool DataInitializationCompiler::Scan( + const parser::DataStmtObject &object) { return std::visit( common::visitors{ [&](const common::Indirection &var) { @@ -126,7 +132,8 @@ bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) { object.u); } -bool DataInitializationCompiler::Scan(const parser::Variable &var) { +template +bool DataInitializationCompiler::Scan(const parser::Variable &var) { if (const auto *expr{GetExpr(var)}) { exprAnalyzer_.GetFoldingContext().messages().SetLocation(var.GetSource()); if (InitDesignator(*expr)) { @@ -136,7 +143,9 @@ bool DataInitializationCompiler::Scan(const parser::Variable &var) { return false; } -bool DataInitializationCompiler::Scan(const parser::Designator &designator) { +template +bool DataInitializationCompiler::Scan( + const parser::Designator &designator) { if (auto expr{exprAnalyzer_.Analyze(designator)}) { exprAnalyzer_.GetFoldingContext().messages().SetLocation( parser::FindSourceLocation(designator)); @@ -147,7 +156,8 @@ bool DataInitializationCompiler::Scan(const parser::Designator &designator) { return false; } -bool DataInitializationCompiler::Scan(const parser::DataImpliedDo &ido) { +template +bool DataInitializationCompiler::Scan(const parser::DataImpliedDo &ido) { const auto &bounds{std::get(ido.t)}; auto name{bounds.name.thing.thing}; const auto *lowerExpr{GetExpr(bounds.lower.thing.thing)}; @@ -201,7 +211,9 @@ bool DataInitializationCompiler::Scan(const parser::DataImpliedDo &ido) { return false; } -bool DataInitializationCompiler::Scan(const parser::DataIDoObject &object) { +template +bool DataInitializationCompiler::Scan( + const parser::DataIDoObject &object) { return std::visit( common::visitors{ [&](const parser::Scalar> @@ -213,7 +225,16 @@ bool DataInitializationCompiler::Scan(const parser::DataIDoObject &object) { object.u); } -bool DataInitializationCompiler::InitDesignator(const SomeExpr &designator) { +template +bool DataInitializationCompiler::Scan(const Symbol &symbol) { + auto designator{exprAnalyzer_.Designate(evaluate::DataRef{symbol})}; + CHECK(designator.has_value()); + return InitDesignator(*designator); +} + +template +bool DataInitializationCompiler::InitDesignator( + const SomeExpr &designator) { evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; evaluate::DesignatorFolder folder{context}; while (auto offsetSymbol{folder.FoldDesignator(designator)}) { @@ -237,8 +258,9 @@ bool DataInitializationCompiler::InitDesignator(const SomeExpr &designator) { return folder.isEmpty(); } +template std::optional> -DataInitializationCompiler::ConvertElement( +DataInitializationCompiler::ConvertElement( const SomeExpr &expr, const evaluate::DynamicType &type) { if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) { return {std::make_pair(std::move(*converted), false)}; @@ -265,7 +287,8 @@ DataInitializationCompiler::ConvertElement( return std::nullopt; } -bool DataInitializationCompiler::InitElement( +template +bool DataInitializationCompiler::InitElement( const evaluate::OffsetSymbol &offsetSymbol, const SomeExpr &designator) { const Symbol &symbol{offsetSymbol.symbol()}; const Symbol *lastSymbol{GetLastSymbol(designator)}; @@ -401,7 +424,8 @@ bool DataInitializationCompiler::InitElement( void AccumulateDataInitializations(DataInitializations &inits, evaluate::ExpressionAnalyzer &exprAnalyzer, const parser::DataStmtSet &set) { - DataInitializationCompiler scanner{inits, exprAnalyzer, set}; + DataInitializationCompiler scanner{ + inits, exprAnalyzer, std::get>(set.t)}; for (const auto &object : std::get>(set.t)) { if (!scanner.Scan(object)) { @@ -414,6 +438,17 @@ void AccumulateDataInitializations(DataInitializations &inits, } } +void AccumulateDataInitializations(DataInitializations &inits, + evaluate::ExpressionAnalyzer &exprAnalyzer, const Symbol &symbol, + const std::list> &list) { + DataInitializationCompiler> + scanner{inits, exprAnalyzer, list}; + if (scanner.Scan(symbol) && scanner.HasSurplusValues()) { + exprAnalyzer.context().Say( + "DATA statement set has more values than objects"_err_en_US); + } +} + // Looks for default derived type component initialization -- but // *not* allocatables. static const DerivedTypeSpec *HasDefaultInitialization(const Symbol &symbol) { diff --git a/flang/lib/Semantics/data-to-inits.h b/flang/lib/Semantics/data-to-inits.h index fd07396d2209..d39a9a39bcc4 100644 --- a/flang/lib/Semantics/data-to-inits.h +++ b/flang/lib/Semantics/data-to-inits.h @@ -17,6 +17,7 @@ namespace Fortran::parser { struct DataStmtSet; +struct DataStmtValue; } namespace Fortran::evaluate { class ExpressionAnalyzer; @@ -40,6 +41,11 @@ using DataInitializations = std::map; void AccumulateDataInitializations(DataInitializations &, evaluate::ExpressionAnalyzer &, const parser::DataStmtSet &); +// For legacy DATA-style initialization extension: integer n(2)/1,2/ +void AccumulateDataInitializations(DataInitializations &, + evaluate::ExpressionAnalyzer &, const Symbol &, + const std::list> &); + void ConvertToInitializers( DataInitializations &, evaluate::ExpressionAnalyzer &); diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp index 0f1507185979..20038c64319d 100644 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -44,16 +44,13 @@ struct ModHeader { static std::optional GetSubmoduleParent(const parser::Program &); static void CollectSymbols(const Scope &, SymbolVector &, SymbolVector &); -static void PutEntity(llvm::raw_ostream &, const Symbol &); -static void PutObjectEntity(llvm::raw_ostream &, const Symbol &); -static void PutProcEntity(llvm::raw_ostream &, const Symbol &); static void PutPassName(llvm::raw_ostream &, const std::optional &); -static void PutTypeParam(llvm::raw_ostream &, const Symbol &); -static void PutEntity( - llvm::raw_ostream &, const Symbol &, std::function, Attrs); static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &); static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &); static void PutBound(llvm::raw_ostream &, const Bound &); +static void PutShapeSpec(llvm::raw_ostream &, const ShapeSpec &); +static void PutShape( + llvm::raw_ostream &, const ArraySpec &, char open, char close); llvm::raw_ostream &PutAttrs(llvm::raw_ostream &, Attrs, const std::string * = nullptr, std::string before = ","s, std::string after = ""s); @@ -177,7 +174,7 @@ std::string ModFileWriter::GetAsString(const Symbol &symbol) { } // Put out the visible symbols from scope. -bool ModFileWriter::PutSymbols(const Scope &scope) { +void ModFileWriter::PutSymbols(const Scope &scope) { SymbolVector sorted; SymbolVector uses; CollectSymbols(scope, sorted, uses); @@ -203,6 +200,41 @@ bool ModFileWriter::PutSymbols(const Scope &scope) { decls_ << ")\n"; } } + CHECK(typeBindings.str().empty()); +} + +// Emit components in order +bool ModFileWriter::PutComponents(const Symbol &typeSymbol) { + const auto &scope{DEREF(typeSymbol.scope())}; + std::string buf; // stuff after CONTAINS in derived type + llvm::raw_string_ostream typeBindings{buf}; + UnorderedSymbolSet emitted; + SymbolVector symbols{scope.GetSymbols()}; + // Emit type parameters first + for (const Symbol &symbol : symbols) { + if (symbol.has()) { + PutSymbol(typeBindings, symbol); + emitted.emplace(symbol); + } + } + // Emit components in component order. + const auto &details{typeSymbol.get()}; + for (SourceName name : details.componentNames()) { + auto iter{scope.find(name)}; + if (iter != scope.end()) { + const Symbol &component{*iter->second}; + if (!component.test(Symbol::Flag::ParentComp)) { + PutSymbol(typeBindings, component); + } + emitted.emplace(component); + } + } + // Emit remaining symbols from the type's scope + for (const Symbol &symbol : symbols) { + if (emitted.find(symbol) == emitted.end()) { + PutSymbol(typeBindings, symbol); + } + } if (auto str{typeBindings.str()}; !str.empty()) { CHECK(scope.IsDerivedType()); decls_ << "contains\n" << str; @@ -295,14 +327,18 @@ void ModFileWriter::PutSymbol( symbol.details()); } -void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) { +void ModFileWriter::PutDerivedType( + const Symbol &typeSymbol, const Scope *scope) { auto &details{typeSymbol.get()}; + if (details.isDECStructure()) { + PutDECStructure(typeSymbol, scope); + return; + } PutAttrs(decls_ << "type", typeSymbol.attrs()); if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) { decls_ << ",extends(" << extends->name() << ')'; } decls_ << "::" << typeSymbol.name(); - auto &typeScope{*typeSymbol.scope()}; if (!details.paramNames().empty()) { char sep{'('}; for (const auto &name : details.paramNames()) { @@ -315,7 +351,7 @@ void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) { if (details.sequence()) { decls_ << "sequence\n"; } - bool contains{PutSymbols(typeScope)}; + bool contains{PutComponents(typeSymbol)}; if (!details.finals().empty()) { const char *sep{contains ? "final::" : "contains\nfinal::"}; for (const auto &pair : details.finals()) { @@ -329,6 +365,47 @@ void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) { decls_ << "end type\n"; } +void ModFileWriter::PutDECStructure( + const Symbol &typeSymbol, const Scope *scope) { + if (emittedDECStructures_.find(typeSymbol) != emittedDECStructures_.end()) { + return; + } + if (!scope && context_.IsTempName(typeSymbol.name().ToString())) { + return; // defer until used + } + emittedDECStructures_.insert(typeSymbol); + decls_ << "structure "; + if (!context_.IsTempName(typeSymbol.name().ToString())) { + decls_ << typeSymbol.name(); + } + if (scope && scope->kind() == Scope::Kind::DerivedType) { + // Nested STRUCTURE: emit entity declarations right now + // on the STRUCTURE statement. + bool any{false}; + for (const auto &ref : scope->GetSymbols()) { + const auto *object{ref->detailsIf()}; + if (object && object->type() && + object->type()->category() == DeclTypeSpec::TypeDerived && + &object->type()->derivedTypeSpec().typeSymbol() == &typeSymbol) { + if (any) { + decls_ << ','; + } else { + any = true; + } + decls_ << ref->name(); + PutShape(decls_, object->shape(), '(', ')'); + PutInit(decls_, *ref, object->init()); + emittedDECFields_.insert(*ref); + } else if (any) { + break; // any later use of this structure will use RECORD/str/ + } + } + } + decls_ << '\n'; + PutComponents(typeSymbol); + decls_ << "end structure\n"; +} + // Attributes that may be in a subprogram prefix static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE, Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE}; @@ -516,7 +593,7 @@ void CollectSymbols( sorted.end() - commonSize, sorted.end(), SymbolSourcePositionCompare{}); } -void PutEntity(llvm::raw_ostream &os, const Symbol &symbol) { +void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol) { std::visit( common::visitors{ [&](const ObjectEntityDetails &) { PutObjectEntity(os, symbol); }, @@ -561,8 +638,19 @@ void PutShape( } } -void PutObjectEntity(llvm::raw_ostream &os, const Symbol &symbol) { +void ModFileWriter::PutObjectEntity( + llvm::raw_ostream &os, const Symbol &symbol) { auto &details{symbol.get()}; + if (details.type() && + details.type()->category() == DeclTypeSpec::TypeDerived) { + const Symbol &typeSymbol{details.type()->derivedTypeSpec().typeSymbol()}; + if (typeSymbol.get().isDECStructure()) { + PutDerivedType(typeSymbol, &symbol.owner()); + if (emittedDECFields_.find(symbol) != emittedDECFields_.end()) { + return; // symbol was emitted on STRUCTURE statement + } + } + } PutEntity( os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); }, symbol.attrs()); @@ -572,7 +660,7 @@ void PutObjectEntity(llvm::raw_ostream &os, const Symbol &symbol) { os << '\n'; } -void PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) { +void ModFileWriter::PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) { if (symbol.attrs().test(Attr::INTRINSIC)) { os << "intrinsic::" << symbol.name() << '\n'; if (symbol.attrs().test(Attr::PRIVATE)) { @@ -608,7 +696,8 @@ void PutPassName( os << ",pass(" << *passName << ')'; } } -void PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) { + +void ModFileWriter::PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) { auto &details{symbol.get()}; PutEntity( os, symbol, @@ -650,11 +739,16 @@ void PutBound(llvm::raw_ostream &os, const Bound &x) { // Write an entity (object or procedure) declaration. // writeType is called to write out the type. -void PutEntity(llvm::raw_ostream &os, const Symbol &symbol, +void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol, std::function writeType, Attrs attrs) { writeType(); PutAttrs(os, attrs, symbol.GetBindName()); - os << "::" << symbol.name(); + if (symbol.owner().kind() == Scope::Kind::DerivedType && + context_.IsTempName(symbol.name().ToString())) { + os << "::%FILL"; + } else { + os << "::" << symbol.name(); + } } // Put out each attribute to os, surrounded by `before` and `after` and diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h index fb8e6a070fa2..1647928613f2 100644 --- a/flang/lib/Semantics/mod-file.h +++ b/flang/lib/Semantics/mod-file.h @@ -10,6 +10,7 @@ #define FORTRAN_SEMANTICS_MOD_FILE_H_ #include "flang/Semantics/attr.h" +#include "flang/Semantics/symbol.h" #include "llvm/Support/raw_ostream.h" #include @@ -42,6 +43,8 @@ private: std::string useExtraAttrsBuf_; std::string declsBuf_; std::string containsBuf_; + // Tracks nested DEC structures and fields of that type + UnorderedSymbolSet emittedDECStructures_, emittedDECFields_; llvm::raw_string_ostream uses_{usesBuf_}; llvm::raw_string_ostream useExtraAttrs_{ @@ -53,10 +56,18 @@ private: void WriteOne(const Scope &); void Write(const Symbol &); std::string GetAsString(const Symbol &); + void PutSymbols(const Scope &); // Returns true if a derived type with bindings and "contains" was emitted - bool PutSymbols(const Scope &); + bool PutComponents(const Symbol &); void PutSymbol(llvm::raw_ostream &, const Symbol &); - void PutDerivedType(const Symbol &); + void PutEntity(llvm::raw_ostream &, const Symbol &); + void PutEntity( + llvm::raw_ostream &, const Symbol &, std::function, Attrs); + void PutObjectEntity(llvm::raw_ostream &, const Symbol &); + void PutProcEntity(llvm::raw_ostream &, const Symbol &); + void PutDerivedType(const Symbol &, const Scope * = nullptr); + void PutDECStructure(const Symbol &, const Scope * = nullptr); + void PutTypeParam(llvm::raw_ostream &, const Symbol &); void PutSubprogram(const Symbol &); void PutGeneric(const Symbol &); void PutUse(const Symbol &); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 679af0be8660..5b0b04093672 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -837,7 +837,7 @@ public: void Post(const parser::DeclarationTypeSpec::Type &); bool Pre(const parser::DeclarationTypeSpec::Class &); void Post(const parser::DeclarationTypeSpec::Class &); - bool Pre(const parser::DeclarationTypeSpec::Record &); + void Post(const parser::DeclarationTypeSpec::Record &); void Post(const parser::DerivedTypeSpec &); bool Pre(const parser::DerivedTypeDef &); bool Pre(const parser::DerivedTypeStmt &); @@ -850,6 +850,7 @@ public: bool Pre(const parser::ComponentDefStmt &) { return BeginDecl(); } void Post(const parser::ComponentDefStmt &) { EndDecl(); } void Post(const parser::ComponentDecl &); + void Post(const parser::FillDecl &); bool Pre(const parser::ProcedureDeclarationStmt &); void Post(const parser::ProcedureDeclarationStmt &); bool Pre(const parser::DataComponentDefStmt &); // returns false @@ -867,6 +868,10 @@ public: void Post(const parser::TypeBoundProcedureStmt::WithInterface &); void Post(const parser::FinalProcedureStmt &); bool Pre(const parser::TypeBoundGenericStmt &); + bool Pre(const parser::StructureDef &); // returns false + bool Pre(const parser::Union::UnionStmt &); + bool Pre(const parser::StructureField &); + void Post(const parser::StructureField &); bool Pre(const parser::AllocateStmt &); void Post(const parser::AllocateStmt &); bool Pre(const parser::StructureConstructor &); @@ -945,7 +950,8 @@ private: std::optional length; std::optional kind; } charInfo_; - // Info about current derived type while walking DerivedTypeDef + // Info about current derived type or STRUCTURE while walking + // DerivedTypeDef / StructureDef struct { const parser::Name *extends{nullptr}; // EXTENDS(name) bool privateComps{false}; // components are private by default @@ -953,6 +959,7 @@ private: bool sawContains{false}; // currently processing bindings bool sequence{false}; // is a sequence type const Symbol *type{nullptr}; // derived type being defined + bool isStructure{false}; // is a DEC STRUCTURE } derivedTypeInfo_; // In a ProcedureDeclarationStmt or ProcComponentDefStmt, this is // the interface name, if any. @@ -3956,11 +3963,6 @@ void DeclarationVisitor::Post( } } -bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) { - // TODO - return true; -} - void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { const auto &typeName{std::get(x.t)}; auto spec{ResolveDerivedType(typeName)}; @@ -4036,6 +4038,22 @@ void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { x.derivedTypeSpec = &GetDeclTypeSpec()->derivedTypeSpec(); } +void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Record &rec) { + const auto &typeName{rec.v}; + if (auto spec{ResolveDerivedType(typeName)}) { + spec->CookParameters(GetFoldingContext()); + spec->EvaluateParameters(context()); + if (const DeclTypeSpec * + extant{currScope().FindInstantiatedDerivedType( + *spec, DeclTypeSpec::TypeDerived)}) { + SetDeclTypeSpec(*extant); + } else { + Say(typeName.source, "%s is not a known STRUCTURE"_err_en_US, + typeName.source); + } + } +} + // The descendents of DerivedTypeDef in the parse tree are visited directly // in this Pre() routine so that recursive use of the derived type can be // supported in the components. @@ -4095,22 +4113,6 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) { if (derivedTypeInfo_.extends) { // C735 Say(stmt.source, "A sequence type may not have the EXTENDS attribute"_err_en_US); - } else { - for (const auto &componentName : details.componentNames()) { - const Symbol *componentSymbol{scope.FindComponent(componentName)}; - if (componentSymbol && componentSymbol->has()) { - const auto &componentDetails{ - componentSymbol->get()}; - const DeclTypeSpec *componentType{componentDetails.type()}; - if (componentType && // C740 - !componentType->AsIntrinsic() && - !componentType->IsSequenceType()) { - Say(componentSymbol->name(), - "A sequence type data component must either be of an" - " intrinsic type or a derived sequence type"_err_en_US); - } - } - } } } Walk(std::get>(x.t)); @@ -4119,6 +4121,7 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) { PopScope(); return false; } + bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &) { return BeginAttrs(); } @@ -4264,6 +4267,16 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) { ClearArraySpec(); ClearCoarraySpec(); } +void DeclarationVisitor::Post(const parser::FillDecl &x) { + // Replace "%FILL" with a distinct generated name + const auto &name{std::get(x.t)}; + const_cast(name.source) = context().GetTempName(currScope()); + if (OkToAddComponent(name)) { + auto &symbol{DeclareObjectEntity(name, GetAttrs())}; + currScope().symbol()->get().add_component(symbol); + } + ClearArraySpec(); +} bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &) { CHECK(!interfaceName_); return BeginDecl(); @@ -4280,7 +4293,15 @@ bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) { GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})); Walk(std::get(x.t)); set_allowForwardReferenceToDerivedType(false); - Walk(std::get>(x.t)); + if (derivedTypeInfo_.sequence) { // C740 + if (const auto *declType{GetDeclTypeSpec()}) { + if (!declType->AsIntrinsic() && !declType->IsSequenceType()) { + Say("A sequence type data component must either be of an" + " intrinsic type or a derived sequence type"_err_en_US); + } + } + } + Walk(std::get>(x.t)); return false; } bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) { @@ -4302,7 +4323,6 @@ void DeclarationVisitor::Post(const parser::ProcInterface &x) { NoteInterfaceName(*name); } } - void DeclarationVisitor::Post(const parser::ProcDecl &x) { const auto &name{std::get(x.t)}; ProcInterface interface; @@ -4502,6 +4522,80 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) { return false; } +// DEC STRUCTUREs are handled thus to allow for nested definitions. +bool DeclarationVisitor::Pre(const parser::StructureDef &def) { + const auto &structureStatement{ + std::get>(def.t)}; + auto saveDerivedTypeInfo{derivedTypeInfo_}; + derivedTypeInfo_ = {}; + derivedTypeInfo_.isStructure = true; + derivedTypeInfo_.sequence = true; + Scope *previousStructure{nullptr}; + if (saveDerivedTypeInfo.isStructure) { + previousStructure = &currScope(); + PopScope(); + } + const parser::StructureStmt &structStmt{structureStatement.statement}; + const auto &name{std::get>(structStmt.t)}; + if (!name) { + // Construct a distinct generated name for an anonymous structure + auto &mutableName{const_cast &>(name)}; + mutableName.emplace( + parser::Name{context().GetTempName(currScope()), nullptr}); + } + auto &symbol{MakeSymbol(*name, DerivedTypeDetails{})}; + symbol.ReplaceName(name->source); + symbol.get().set_sequence(true); + symbol.get().set_isDECStructure(true); + derivedTypeInfo_.type = &symbol; + PushScope(Scope::Kind::DerivedType, &symbol); + const auto &fields{std::get>(def.t)}; + Walk(fields); + PopScope(); + // Complete the definition + DerivedTypeSpec derivedTypeSpec{symbol.name(), symbol}; + derivedTypeSpec.set_scope(DEREF(symbol.scope())); + derivedTypeSpec.CookParameters(GetFoldingContext()); + derivedTypeSpec.EvaluateParameters(context()); + DeclTypeSpec &type{currScope().MakeDerivedType( + DeclTypeSpec::TypeDerived, std::move(derivedTypeSpec))}; + type.derivedTypeSpec().Instantiate(currScope()); + // Restore previous structure definition context, if any + derivedTypeInfo_ = saveDerivedTypeInfo; + if (previousStructure) { + PushScope(*previousStructure); + } + // Handle any entity declarations on the STRUCTURE statement + const auto &decls{std::get>(structStmt.t)}; + if (!decls.empty()) { + BeginDecl(); + SetDeclTypeSpec(type); + Walk(decls); + EndDecl(); + } + return false; +} + +bool DeclarationVisitor::Pre(const parser::Union::UnionStmt &) { + Say("UNION is not yet supported"_err_en_US); // TODO + return true; +} + +bool DeclarationVisitor::Pre(const parser::StructureField &x) { + if (std::holds_alternative>( + x.u)) { + BeginDecl(); + } + return true; +} + +void DeclarationVisitor::Post(const parser::StructureField &x) { + if (std::holds_alternative>( + x.u)) { + EndDecl(); + } +} + bool DeclarationVisitor::Pre(const parser::AllocateStmt &) { BeginDeclTypeSpec(); return true; @@ -4900,14 +4994,15 @@ void DeclarationVisitor::CheckCommonBlockDerivedType( component.name(), "Component with ALLOCATABLE attribute"_en_US); return; } - if (const auto *details{component.detailsIf()}) { - if (details->init()) { - Say2(name, - "Derived type variable '%s' may not appear in a COMMON block" - " due to component with default initialization"_err_en_US, - component.name(), "Component with default initialization"_en_US); - return; - } + const auto *details{component.detailsIf()}; + if (component.test(Symbol::Flag::InDataStmt) || + (details && details->init())) { + Say2(name, + "Derived type variable '%s' may not appear in a COMMON block due to component with default initialization"_err_en_US, + component.name(), "Component with default initialization"_en_US); + return; + } + if (details) { if (const auto *type{details->type()}) { if (const auto *derived{type->AsDerived()}) { CheckCommonBlockDerivedType(name, derived->typeSymbol()); @@ -6112,15 +6207,11 @@ void DeclarationVisitor::Initialization(const parser::Name &name, // Defer analysis to the end of the specification part // so that forward references and attribute checks like SAVE // work better. + ultimate.set(Symbol::Flag::InDataStmt); }, [&](const std::list> &) { - // 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 - } + // Handled later in data-to-inits conversion + ultimate.set(Symbol::Flag::InDataStmt); }, }, init.u); diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp index 5a5790235be4..4c53df09ee63 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -354,7 +354,8 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())}; // Check for an existing description that can be imported from a USE'd module std::string typeName{dtSymbol->name().ToString()}; - if (typeName.empty() || typeName[0] == '.') { + if (typeName.empty() || + (typeName.front() == '.' && !context_.IsTempName(typeName))) { return nullptr; } std::string distinctName{typeName}; @@ -627,7 +628,7 @@ SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) { SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget( Scope &scope, const std::string &name) { CHECK(!name.empty()); - CHECK(name.front() != '.'); + CHECK(name.front() != '.' || context_.IsTempName(name)); ObjectEntityDetails object; auto len{static_cast(name.size())}; if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{ diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp index 89a4e22f46b4..f1fa2b349739 100644 --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -332,7 +332,7 @@ SourceName SemanticsContext::SaveTempName(std::string &&name) { SourceName SemanticsContext::GetTempName(const Scope &scope) { for (const auto &str : tempNames_) { - if (str.size() > 5 && str.substr(0, 5) == ".F18.") { + if (IsTempName(str)) { SourceName name{str}; if (scope.find(name) == scope.end()) { return name; @@ -342,6 +342,10 @@ SourceName SemanticsContext::GetTempName(const Scope &scope) { return SaveTempName(".F18."s + std::to_string(tempNames_.size())); } +bool SemanticsContext::IsTempName(const std::string &name) { + return name.size() > 5 && name.substr(0, 5) == ".F18."; +} + Scope *SemanticsContext::GetBuiltinModule(const char *name) { return ModFileReader{*this}.Read( SourceName{name, std::strlen(name)}, nullptr, true /*silence errors*/); diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 8c447c95b429..3211bdaac3e3 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -697,7 +697,14 @@ std::string DeclTypeSpec::AsFortran() const { case Character: return characterTypeSpec().AsFortran(); case TypeDerived: - return "TYPE(" + derivedTypeSpec().AsFortran() + ')'; + if (derivedTypeSpec() + .typeSymbol() + .get() + .isDECStructure()) { + return "RECORD" + derivedTypeSpec().typeSymbol().name().ToString(); + } else { + return "TYPE(" + derivedTypeSpec().AsFortran() + ')'; + } case ClassDerived: return "CLASS(" + derivedTypeSpec().AsFortran() + ')'; case TypeStar: diff --git a/flang/test/Semantics/modfile42.f90 b/flang/test/Semantics/modfile42.f90 new file mode 100644 index 000000000000..6d5d50f282d2 --- /dev/null +++ b/flang/test/Semantics/modfile42.f90 @@ -0,0 +1,48 @@ +! RUN: %python %S/test_modfile.py %s %flang_fc1 +! Check legacy DEC structures +module m + structure /s1/ + integer n/1/ + integer na(2)/2,3/ + structure /s1a/ m, ma(2) + integer j/4/ + integer ja(2)/5,6/ + end structure + structure m2(2), m3 ! anonymous + integer k/7/ + integer %fill(3) + integer ka(2)/8,9/ + real %fill(2) + end structure + end structure + record/s1/ ra1, rb1 + record/s1a/ ra1a + common/s1/ foo ! not a name conflict + character*8 s1 ! not a name conflict + integer t(2) /2*10/ ! DATA-like entity initialization +end + +!Expect: m.mod +!module m +!structure /s1/ +!integer(4)::n=1_4 +!integer(4)::na(1_8:2_8)=[INTEGER(4)::2_4,3_4] +!structure /s1a/m,ma(1_8:2_8) +!integer(4)::j=4_4 +!integer(4)::ja(1_8:2_8)=[INTEGER(4)::5_4,6_4] +!end structure +!structure m2(1_8:2_8),m3 +!integer(4)::k=7_4 +!integer(4)::%FILL(1_8:3_8) +!integer(4)::ka(1_8:2_8)=[INTEGER(4)::8_4,9_4] +!real(4)::%FILL(1_8:2_8) +!end structure +!end structure +!record/s1/::ra1 +!record/s1/::rb1 +!record/s1a/::ra1a +!real(4)::foo +!character(8_8,1)::s1 +!integer(4)::t(1_8:2_8) +!common/s1/foo +!end diff --git a/flang/test/Semantics/struct01.f90 b/flang/test/Semantics/struct01.f90 new file mode 100644 index 000000000000..85d1159ba1db --- /dev/null +++ b/flang/test/Semantics/struct01.f90 @@ -0,0 +1,19 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for new semantic errors from misuse of the DEC STRUCTURE extension +program main + !ERROR: Derived type '/undeclared/' not found + record /undeclared/ var + structure /s/ + !ERROR: /s/ is not a known STRUCTURE + record /s/ attemptToRecurse + !ERROR: UNION is not yet supported + union + map + integer j + end map + map + real x + end map + end union + end structure +end diff --git a/flang/test/Semantics/symbol15.f90 b/flang/test/Semantics/symbol15.f90 index 97dc50a23845..318819e224cd 100644 --- a/flang/test/Semantics/symbol15.f90 +++ b/flang/test/Semantics/symbol15.f90 @@ -14,10 +14,10 @@ module m !DEF: /m/op2 POINTER, PUBLIC ObjectEntity REAL(4) !DEF: /m/null INTRINSIC, PUBLIC, PURE (Function) ProcEntity real, pointer :: op2 => null() - !DEF: /m/op3 POINTER, PUBLIC ObjectEntity REAL(4) + !DEF: /m/op3 POINTER, PUBLIC (InDataStmt) ObjectEntity REAL(4) !DEF: /m/x PUBLIC, TARGET ObjectEntity REAL(4) real, pointer :: op3 => x - !DEF: /m/op4 POINTER, PUBLIC ObjectEntity REAL(4) + !DEF: /m/op4 POINTER, PUBLIC (InDataStmt) ObjectEntity REAL(4) !DEF: /m/y PUBLIC, TARGET ObjectEntity REAL(4) real, pointer :: op4 => y(1) !REF: /m/iface @@ -50,10 +50,10 @@ module m !DEF: /m/t1/opc2 POINTER ObjectEntity REAL(4) !REF: /m/null real, pointer :: opc2 => null() - !DEF: /m/t1/opc3 POINTER ObjectEntity REAL(4) + !DEF: /m/t1/opc3 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/x real, pointer :: opc3 => x - !DEF: /m/t1/opc4 POINTER ObjectEntity REAL(4) + !DEF: /m/t1/opc4 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/y real, pointer :: opc4 => y(1) !REF: /m/iface @@ -100,10 +100,10 @@ module m !DEF: /m/pdt1/opc2 POINTER ObjectEntity REAL(4) !REF: /m/null real, pointer :: opc2 => null() - !DEF: /m/pdt1/opc3 POINTER ObjectEntity REAL(4) + !DEF: /m/pdt1/opc3 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/x real, pointer :: opc3 => x - !DEF: /m/pdt1/opc4 POINTER ObjectEntity REAL(4) + !DEF: /m/pdt1/opc4 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/y !REF: /m/pdt1/k real, pointer :: opc4 => y(k) @@ -160,10 +160,10 @@ module m subroutine ext2 end subroutine end interface - !DEF: /m/op10 POINTER, PUBLIC ObjectEntity REAL(4) + !DEF: /m/op10 POINTER, PUBLIC(InDataStmt) ObjectEntity REAL(4) !REF: /m/x real, pointer :: op10 => x - !DEF: /m/op11 POINTER, PUBLIC ObjectEntity REAL(4) + !DEF: /m/op11 POINTER, PUBLIC(InDataStmt) ObjectEntity REAL(4) !REF: /m/y real, pointer :: op11 => y(1) !REF: /m/iface @@ -176,10 +176,10 @@ module m procedure(iface), pointer :: pp11 => ext2 !DEF: /m/t2 PUBLIC DerivedType type :: t2 - !DEF: /m/t2/opc10 POINTER ObjectEntity REAL(4) + !DEF: /m/t2/opc10 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/x real, pointer :: opc10 => x - !DEF: /m/t2/opc11 POINTER ObjectEntity REAL(4) + !DEF: /m/t2/opc11 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/y real, pointer :: opc11 => y(1) !REF: /m/iface @@ -203,10 +203,10 @@ module m type :: pdt2(k) !REF: /m/pdt2/k integer, kind :: k - !DEF: /m/pdt2/opc10 POINTER ObjectEntity REAL(4) + !DEF: /m/pdt2/opc10 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/x real, pointer :: opc10 => x - !DEF: /m/pdt2/opc11 POINTER ObjectEntity REAL(4) + !DEF: /m/pdt2/opc11 POINTER (InDataStmt) ObjectEntity REAL(4) !REF: /m/y !REF: /m/pdt2/k real, pointer :: opc11 => y(k)