[flang-commits] [flang] c14cf92 - [flang] Implement semantics for DEC STRUCTURE/RECORD
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Jan 13 13:17:20 PST 2022
Author: Peter Klausler
Date: 2022-01-13T13:17:13-08:00
New Revision: c14cf92b5a1cb13a33786291604c24a42e51b8eb
URL: https://github.com/llvm/llvm-project/commit/c14cf92b5a1cb13a33786291604c24a42e51b8eb
DIFF: https://github.com/llvm/llvm-project/commit/c14cf92b5a1cb13a33786291604c24a42e51b8eb.diff
LOG: [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
Added:
flang/test/Semantics/modfile42.f90
flang/test/Semantics/struct01.f90
Modified:
flang/docs/Extensions.md
flang/include/flang/Common/unwrap.h
flang/include/flang/Parser/dump-parse-tree.h
flang/include/flang/Parser/parse-tree.h
flang/include/flang/Parser/tools.h
flang/include/flang/Parser/user-state.h
flang/include/flang/Semantics/expression.h
flang/include/flang/Semantics/semantics.h
flang/include/flang/Semantics/symbol.h
flang/lib/Evaluate/fold-designator.cpp
flang/lib/Parser/Fortran-parsers.cpp
flang/lib/Parser/unparse.cpp
flang/lib/Parser/user-state.cpp
flang/lib/Semantics/check-data.cpp
flang/lib/Semantics/check-data.h
flang/lib/Semantics/data-to-inits.cpp
flang/lib/Semantics/data-to-inits.h
flang/lib/Semantics/mod-file.cpp
flang/lib/Semantics/mod-file.h
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/lib/Semantics/semantics.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/symbol15.f90
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 7bcea54b0f520..e01c4d7ef37ba 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 339b6a77edc03..b6ea4a1546096 100644
--- a/flang/include/flang/Common/unwrap.h
+++ b/flang/include/flang/Common/unwrap.h
@@ -128,7 +128,7 @@ struct UnwrapperHelper {
template <typename A, typename B, bool COPY>
static auto Unwrap(const Indirection<B, COPY> &p) -> Constify<A, B> * {
- return Unwrap<A>(*p);
+ return Unwrap<A>(p.value());
}
template <typename A, typename B>
diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
index 150b011ad8ba0..cf85194c0d0fa 100644
--- a/flang/include/flang/Parser/dump-parse-tree.h
+++ b/flang/include/flang/Parser/dump-parse-tree.h
@@ -195,6 +195,8 @@ class ParseTreeDumper {
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 6820a874483d0..f0a97402204e0 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<Name, std::optional<ComponentArraySpec>, std::optional<CharLength>>
+ t;
+};
+
+struct ComponentOrFill {
+ UNION_CLASS_BOILERPLATE(ComponentOrFill);
+ std::variant<ComponentDecl, FillDecl> u;
+};
+
// R737 data-component-def-stmt ->
// declaration-type-spec [[, component-attr-spec-list] ::]
// component-decl-list
struct DataComponentDefStmt {
TUPLE_CLASS_BOILERPLATE(DataComponentDefStmt);
std::tuple<DeclarationTypeSpec, std::list<ComponentAttrSpec>,
- std::list<ComponentDecl>>
+ std::list<ComponentOrFill>>
t;
};
@@ -3258,7 +3271,7 @@ struct Union {
struct StructureStmt {
TUPLE_CLASS_BOILERPLATE(StructureStmt);
- std::tuple<Name, bool /*slashes*/, std::list<EntityDecl>> t;
+ std::tuple<std::optional<Name>, std::list<EntityDecl>> t;
};
struct StructureDef {
diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h
index ccd49d2a790e2..0261d8f0cf48e 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 6a4cf9736f1ff..61745a833c715 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<DataComponentDefStmt> Parse(ParseState &);
};
+
+struct NestedStructureStmt {
+ using resultType = StructureStmt;
+ static std::optional<StructureStmt> 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 203a88937728a..fd649308d7d66 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -247,6 +247,9 @@ class ExpressionAnalyzer {
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 @@ class ExpressionAnalyzer {
const std::list<parser::SectionSubscript> &);
std::optional<Component> CreateComponent(
DataRef &&, const Symbol &, const semantics::Scope &);
- MaybeExpr Designate(DataRef &&);
MaybeExpr CompleteSubscripts(ArrayRef &&);
MaybeExpr ApplySubscripts(DataRef &&, std::vector<Subscript> &&);
MaybeExpr TopLevelChecks(DataRef &&);
diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h
index 07498c46bc43f..078c8a026e74b 100644
--- a/flang/include/flang/Semantics/semantics.h
+++ b/flang/include/flang/Semantics/semantics.h
@@ -173,6 +173,7 @@ class SemanticsContext {
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 b124f03828329..361d69e849213 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -255,6 +255,7 @@ class DerivedTypeDetails {
const std::list<SourceName> ¶mNames() const { return paramNames_; }
const SymbolVector ¶mDecls() const { return paramDecls_; }
bool sequence() const { return sequence_; }
+ bool isDECStructure() const { return isDECStructure_; }
std::map<SourceName, SymbolRef> &finals() { return finals_; }
const std::map<SourceName, SymbolRef> &finals() const { return finals_; }
bool isForwardReferenced() const { return isForwardReferenced_; }
@@ -262,6 +263,7 @@ class DerivedTypeDetails {
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<SourceName> &componentNames() const {
return componentNames_;
@@ -292,6 +294,7 @@ class DerivedTypeDetails {
std::list<SourceName> componentNames_;
std::map<SourceName, SymbolRef> 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 @@ class Symbol {
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 c4f072e1c4b23..45ae691d4b849 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<OffsetSymbol> 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<OffsetSymbol> DesignatorFolder::FoldDesignator(
if (auto bytes{ToInt64(
type->MeasureSizeInBytes(context_, GetRank(*extents) > 0))}) {
OffsetSymbol result{symbol, static_cast<std::size_t>(*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<OffsetSymbol> DesignatorFolder::FoldDesignator(
const Component &component, ConstantSubscript which) {
const Symbol &comp{component.GetLastSymbol()};
const DataRef &base{component.base()};
- std::optional<OffsetSymbol> result, baseResult;
+ std::optional<OffsetSymbol> 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 de59b26d58154..a7d57954c6f70 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<DeclarationTypeSpec::ClassStar>())) ||
extension<LanguageFeature::DECStructures>(
construct<DeclarationTypeSpec>(
+ // As is also done for the STRUCTURE statement, the name of
+ // the structure includes the surrounding slashes to avoid
+ // name clashes.
construct<DeclarationTypeSpec::Record>(
- "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<DataComponentDefStmt>(declarationTypeSpec,
optionalListBeforeColons(Parser<ComponentAttrSpec>{}),
- nonemptyList(
- "expected component declarations"_err_en_US, Parser<ComponentDecl>{})))
+ nonemptyList("expected component declarations"_err_en_US,
+ Parser<ComponentOrFill>{})))
// R738 component-attr-spec ->
// access-spec | ALLOCATABLE |
@@ -426,6 +429,13 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
TYPE_CONTEXT_PARSER("component declaration"_en_US,
construct<ComponentDecl>(name, maybe(Parser<ComponentArraySpec>{}),
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<LanguageFeature::DECStructures>(
+ construct<FillDecl>(space >> sourced("%FILL" >> construct<Name>()),
+ maybe(Parser<ComponentArraySpec>{}), maybe("*" >> charLength))))
+TYPE_PARSER(construct<ComponentOrFill>(Parser<ComponentDecl>{}) ||
+ construct<ComponentOrFill>(Parser<FillDecl>{}))
// R740 component-array-spec ->
// explicit-shape-spec-list | deferred-shape-spec-list
@@ -1180,14 +1190,21 @@ TYPE_PARSER(extension<LanguageFeature::CrayPointer>(construct<BasedPointerStmt>(
construct<BasedPointer>("(" >> objectName / ",",
objectName, maybe(Parser<ArraySpec>{}) / ")")))))
-TYPE_PARSER(construct<StructureStmt>("STRUCTURE /" >> name / "/", pure(true),
- optionalList(entityDecl)) ||
- construct<StructureStmt>(
- "STRUCTURE" >> name, pure(false), pure<std::list<EntityDecl>>()))
+// Subtle: the name includes the surrounding slashes, which avoids
+// clashes with other uses of the name in the same scope.
+TYPE_PARSER(construct<StructureStmt>(
+ "STRUCTURE" >> maybe(sourced("/" >> name / "/")), optionalList(entityDecl)))
+
+constexpr auto nestedStructureDef{
+ CONTEXT_PARSER("nested STRUCTURE definition"_en_US,
+ construct<StructureDef>(statement(NestedStructureStmt{}),
+ many(Parser<StructureField>{}),
+ statement(construct<StructureDef::EndStructureStmt>(
+ "END STRUCTURE"_tok))))};
TYPE_PARSER(construct<StructureField>(statement(StructureComponents{})) ||
construct<StructureField>(indirect(Parser<Union>{})) ||
- construct<StructureField>(indirect(Parser<StructureDef>{})))
+ construct<StructureField>(indirect(nestedStructureDef)))
TYPE_CONTEXT_PARSER("STRUCTURE definition"_en_US,
extension<LanguageFeature::DECStructures>(construct<StructureDef>(
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index 075719926e852..39343dfe24958 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -265,18 +265,25 @@ class UnparseVisitor {
void Unparse(const DataComponentDefStmt &x) { // R737
const auto &dts{std::get<DeclarationTypeSpec>(x.t)};
const auto &attrs{std::get<std::list<ComponentAttrSpec>>(x.t)};
- const auto &decls{std::get<std::list<ComponentDecl>>(x.t)};
+ const auto &decls{std::get<std::list<ComponentOrFill>>(x.t)};
Walk(dts), Walk(", ", attrs, ", ");
if (!attrs.empty() ||
(!std::holds_alternative<DeclarationTypeSpec::Record>(dts.u) &&
std::none_of(
- decls.begin(), decls.end(), [](const ComponentDecl &d) {
- const auto &init{
- std::get<std::optional<Initialization>>(d.t)};
- return init &&
- std::holds_alternative<
- std::list<common::Indirection<DataStmtValue>>>(
- init->u);
+ decls.begin(), decls.end(), [](const ComponentOrFill &c) {
+ return std::visit(
+ common::visitors{
+ [](const ComponentDecl &d) {
+ const auto &init{
+ std::get<std::optional<Initialization>>(d.t)};
+ return init &&
+ std::holds_alternative<std::list<
+ common::Indirection<DataStmtValue>>>(
+ init->u);
+ },
+ [](const FillDecl &) { return false; },
+ },
+ c.u);
}))) {
Put(" ::");
}
@@ -310,6 +317,11 @@ class UnparseVisitor {
Walk("*", std::get<std::optional<CharLength>>(x.t));
Walk(std::get<std::optional<Initialization>>(x.t));
}
+ void Unparse(const FillDecl &x) { // DEC extension
+ Put("%FILL");
+ Walk("(", std::get<std::optional<ComponentArraySpec>>(x.t), ")");
+ Walk("*", std::get<std::optional<CharLength>>(x.t));
+ }
void Unparse(const ComponentArraySpec &x) { // R740
std::visit(common::visitors{
[&](const std::list<ExplicitShapeSpec> &y) { Walk(y, ","); },
@@ -2486,21 +2498,19 @@ class UnparseVisitor {
void Unparse(const BasedPointerStmt &x) { Walk("POINTER ", x.v, ","); }
void Post(const StructureField &x) {
if (const auto *def{std::get_if<Statement<DataComponentDefStmt>>(&x.u)}) {
- for (const auto &decl :
- std::get<std::list<ComponentDecl>>(def->statement.t)) {
- structureComponents_.insert(std::get<Name>(decl.t).source);
+ for (const auto &item :
+ std::get<std::list<ComponentOrFill>>(def->statement.t)) {
+ if (const auto *comp{std::get_if<ComponentDecl>(&item.u)}) {
+ structureComponents_.insert(std::get<Name>(comp->t).source);
+ }
}
}
}
void Unparse(const StructureStmt &x) {
Word("STRUCTURE ");
- if (std::get<bool>(x.t)) { // slashes around name
- Put('/'), Walk(std::get<Name>(x.t)), Put('/');
- Walk(" ", std::get<std::list<EntityDecl>>(x.t), ", ");
- } else {
- CHECK(std::get<std::list<EntityDecl>>(x.t).empty());
- Walk(std::get<Name>(x.t));
- }
+ // The name, if present, includes the /slashes/
+ Walk(std::get<std::optional<Name>>(x.t));
+ Walk(" ", std::get<std::list<EntityDecl>>(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 f0bc36cb6bdc3..6423b6a51f287 100644
--- a/flang/lib/Parser/user-state.cpp
+++ b/flang/lib/Parser/user-state.cpp
@@ -63,6 +63,11 @@ std::optional<Success> 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<Name> OldStructureComponentName::Parse(ParseState &state) {
if (std::optional<Name> n{name.Parse(state)}) {
if (const auto *ustate{state.userState()}) {
@@ -80,11 +85,25 @@ std::optional<DataComponentDefStmt> StructureComponents::Parse(
std::optional<DataComponentDefStmt> defs{stmt.Parse(state)};
if (defs) {
if (auto *ustate{state.userState()}) {
- for (const auto &decl : std::get<std::list<ComponentDecl>>(defs->t)) {
- ustate->NoteOldStructureComponent(std::get<Name>(decl.t).source);
+ for (const auto &item : std::get<std::list<ComponentOrFill>>(defs->t)) {
+ if (const auto *decl{std::get_if<ComponentDecl>(&item.u)}) {
+ ustate->NoteOldStructureComponent(std::get<Name>(decl->t).source);
+ }
}
}
}
return defs;
}
+
+std::optional<StructureStmt> NestedStructureStmt::Parse(ParseState &state) {
+ std::optional<StructureStmt> stmt{Parser<StructureStmt>{}.Parse(state)};
+ if (stmt) {
+ if (auto *ustate{state.userState()}) {
+ for (const auto &entity : std::get<std::list<EntityDecl>>(stmt->t)) {
+ ustate->NoteOldStructureComponent(std::get<Name>(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 338bd91f1da05..bd8d836cf3528 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 <typename A> void DataChecker::LegacyDataInit(const A &decl) {
+ if (const auto &init{
+ std::get<std::optional<parser::Initialization>>(decl.t)}) {
+ const Symbol *name{std::get<parser::Name>(decl.t).symbol};
+ const auto *list{
+ std::get_if<std::list<common::Indirection<parser::DataStmtValue>>>(
+ &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 eafecd902cb98..479d32568fa66 100644
--- a/flang/lib/Semantics/check-data.h
+++ b/flang/lib/Semantics/check-data.h
@@ -37,6 +37,9 @@ class DataChecker : public virtual BaseChecker {
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 @@ class DataChecker : public virtual BaseChecker {
template <typename T> void CheckIfConstantSubscript(const T &);
void CheckSubscript(const parser::SectionSubscript &);
bool CheckAllSubscriptsInDataRef(const parser::DataRef &, parser::CharBlock);
+ template <typename A> 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 4f540f3f96441..be8541efda5d4 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 <typename DSV = parser::DataStmtValue> class ValueListIterator {
public:
- explicit ValueListIterator(const parser::DataStmtSet &set)
- : end_{std::get<std::list<parser::DataStmtValue>>(set.t).end()},
- at_{std::get<std::list<parser::DataStmtValue>>(set.t).begin()} {
+ explicit ValueListIterator(const std::list<DSV> &list)
+ : end_{list.end()}, at_{list.begin()} {
SetRepetitionCount();
}
bool hasFatalError() const { return hasFatalError_; }
@@ -56,25 +55,27 @@ class ValueListIterator {
}
private:
- using listIterator = std::list<parser::DataStmtValue>::const_iterator;
+ using listIterator = typename std::list<DSV>::const_iterator;
void SetRepetitionCount();
+ const parser::DataStmtValue &GetValue() const {
+ return DEREF(common::Unwrap<const parser::DataStmtValue>(*at_));
+ }
const parser::DataStmtConstant &GetConstant() const {
- return std::get<parser::DataStmtConstant>(at_->t);
+ return std::get<parser::DataStmtConstant>(GetValue().t);
}
- listIterator end_;
- listIterator at_;
+ listIterator end_, at_;
ConstantSubscript repetitionsRemaining_{0};
bool hasFatalError_{false};
};
-void ValueListIterator::SetRepetitionCount() {
+template <typename DSV> void ValueListIterator<DSV>::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 <typename DSV = parser::DataStmtValue>
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<DSV> &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 @@ class DataInitializationCompiler {
// 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<std::pair<SomeExpr, bool>> ConvertElement(
@@ -112,10 +116,12 @@ class DataInitializationCompiler {
DataInitializations &inits_;
evaluate::ExpressionAnalyzer &exprAnalyzer_;
- ValueListIterator values_;
+ ValueListIterator<DSV> values_;
};
-bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) {
+template <typename DSV>
+bool DataInitializationCompiler<DSV>::Scan(
+ const parser::DataStmtObject &object) {
return std::visit(
common::visitors{
[&](const common::Indirection<parser::Variable> &var) {
@@ -126,7 +132,8 @@ bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) {
object.u);
}
-bool DataInitializationCompiler::Scan(const parser::Variable &var) {
+template <typename DSV>
+bool DataInitializationCompiler<DSV>::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 <typename DSV>
+bool DataInitializationCompiler<DSV>::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 <typename DSV>
+bool DataInitializationCompiler<DSV>::Scan(const parser::DataImpliedDo &ido) {
const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(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 <typename DSV>
+bool DataInitializationCompiler<DSV>::Scan(
+ const parser::DataIDoObject &object) {
return std::visit(
common::visitors{
[&](const parser::Scalar<common::Indirection<parser::Designator>>
@@ -213,7 +225,16 @@ bool DataInitializationCompiler::Scan(const parser::DataIDoObject &object) {
object.u);
}
-bool DataInitializationCompiler::InitDesignator(const SomeExpr &designator) {
+template <typename DSV>
+bool DataInitializationCompiler<DSV>::Scan(const Symbol &symbol) {
+ auto designator{exprAnalyzer_.Designate(evaluate::DataRef{symbol})};
+ CHECK(designator.has_value());
+ return InitDesignator(*designator);
+}
+
+template <typename DSV>
+bool DataInitializationCompiler<DSV>::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 <typename DSV>
std::optional<std::pair<SomeExpr, bool>>
-DataInitializationCompiler::ConvertElement(
+DataInitializationCompiler<DSV>::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 <typename DSV>
+bool DataInitializationCompiler<DSV>::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<std::list<parser::DataStmtValue>>(set.t)};
for (const auto &object :
std::get<std::list<parser::DataStmtObject>>(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<common::Indirection<parser::DataStmtValue>> &list) {
+ DataInitializationCompiler<common::Indirection<parser::DataStmtValue>>
+ 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 fd07396d22099..d39a9a39bcc44 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<const Symbol *, SymbolDataInitialization>;
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<common::Indirection<parser::DataStmtValue>> &);
+
void ConvertToInitializers(
DataInitializations &, evaluate::ExpressionAnalyzer &);
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index 0f15071859790..20038c64319db 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -44,16 +44,13 @@ struct ModHeader {
static std::optional<SourceName> 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<SourceName> &);
-static void PutTypeParam(llvm::raw_ostream &, const Symbol &);
-static void PutEntity(
- llvm::raw_ostream &, const Symbol &, std::function<void()>, 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<TypeParamDetails>()) {
+ PutSymbol(typeBindings, symbol);
+ emitted.emplace(symbol);
+ }
+ }
+ // Emit components in component order.
+ const auto &details{typeSymbol.get<DerivedTypeDetails>()};
+ 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<DerivedTypeDetails>()};
+ 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<ObjectEntityDetails>()};
+ 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<ObjectEntityDetails>()};
+ if (details.type() &&
+ details.type()->category() == DeclTypeSpec::TypeDerived) {
+ const Symbol &typeSymbol{details.type()->derivedTypeSpec().typeSymbol()};
+ if (typeSymbol.get<DerivedTypeDetails>().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<TypeParamDetails>()};
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<void()> 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 fb8e6a070fa2b..1647928613f28 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 <string>
@@ -42,6 +43,8 @@ class ModFileWriter {
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 @@ class ModFileWriter {
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<void()>, 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 679af0be8660a..5b0b04093672d 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -837,7 +837,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
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 @@ class DeclarationVisitor : public ArraySpecVisitor,
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 @@ class DeclarationVisitor : public ArraySpecVisitor,
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 @@ class DeclarationVisitor : public ArraySpecVisitor,
std::optional<ParamValue> length;
std::optional<KindExpr> 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 @@ class DeclarationVisitor : public ArraySpecVisitor,
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<parser::Name>(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<ObjectEntityDetails>()) {
- const auto &componentDetails{
- componentSymbol->get<ObjectEntityDetails>()};
- 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<std::optional<parser::TypeBoundProcedurePart>>(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<parser::Name>(x.t)};
+ const_cast<SourceName &>(name.source) = context().GetTempName(currScope());
+ if (OkToAddComponent(name)) {
+ auto &symbol{DeclareObjectEntity(name, GetAttrs())};
+ currScope().symbol()->get<DerivedTypeDetails>().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<parser::DeclarationTypeSpec>(x.t));
set_allowForwardReferenceToDerivedType(false);
- Walk(std::get<std::list<parser::ComponentDecl>>(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<std::list<parser::ComponentOrFill>>(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<parser::Name>(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<parser::Statement<parser::StructureStmt>>(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<std::optional<parser::Name>>(structStmt.t)};
+ if (!name) {
+ // Construct a distinct generated name for an anonymous structure
+ auto &mutableName{const_cast<std::optional<parser::Name> &>(name)};
+ mutableName.emplace(
+ parser::Name{context().GetTempName(currScope()), nullptr});
+ }
+ auto &symbol{MakeSymbol(*name, DerivedTypeDetails{})};
+ symbol.ReplaceName(name->source);
+ symbol.get<DerivedTypeDetails>().set_sequence(true);
+ symbol.get<DerivedTypeDetails>().set_isDECStructure(true);
+ derivedTypeInfo_.type = &symbol;
+ PushScope(Scope::Kind::DerivedType, &symbol);
+ const auto &fields{std::get<std::list<parser::StructureField>>(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<std::list<parser::EntityDecl>>(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<parser::Statement<parser::DataComponentDefStmt>>(
+ x.u)) {
+ BeginDecl();
+ }
+ return true;
+}
+
+void DeclarationVisitor::Post(const parser::StructureField &x) {
+ if (std::holds_alternative<parser::Statement<parser::DataComponentDefStmt>>(
+ 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<ObjectEntityDetails>()}) {
- 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<ObjectEntityDetails>()};
+ 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<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
- }
+ // 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 5a5790235be4c..4c53df09ee637 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<common::ConstantSubscript>(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 89a4e22f46b4e..f1fa2b349739b 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 8c447c95b4296..3211bdaac3e30 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<DerivedTypeDetails>()
+ .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 0000000000000..6d5d50f282d2f
--- /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 0000000000000..85d1159ba1dbb
--- /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 97dc50a23845f..318819e224cd8 100644
--- a/flang/test/Semantics/symbol15.f90
+++ b/flang/test/Semantics/symbol15.f90
@@ -14,10 +14,10 @@ subroutine iface
!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 @@ subroutine iface
!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 @@ subroutine iface
!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 @@ subroutine iface
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 @@ subroutine ext2
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 @@ subroutine ext2
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)
More information about the flang-commits
mailing list