Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-12-27 02:09:54 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[flang] Implement semantics for DEC STRUCTURE/RECORD

Browse Source 
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
This commit is contained in:
Peter Klausler 2021-12-17 16:48:16 -08:00
parent 71a082f726
commit c14cf92b5a
26 changed files with 566 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
flang/docs/Extensions.md
View File

@ -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`

2
flang/include/flang/Common/unwrap.h
View File

@ -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>

2
flang/include/flang/Parser/dump-parse-tree.h
View File

@ -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)

17
flang/include/flang/Parser/parse-tree.h
View File

@ -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 {

2
flang/include/flang/Parser/tools.h
View File

@ -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 &);

5
flang/include/flang/Parser/user-state.h
View File

@ -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_

4
flang/include/flang/Semantics/expression.h
View File

@ -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<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 &&);

1
flang/include/flang/Semantics/semantics.h
View File

@ -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);

7
flang/include/flang/Semantics/symbol.h
View File

@ -255,6 +255,7 @@ public:
const std::list<SourceName> &paramNames() const { return paramNames_; }
const SymbolVector &paramDecls() 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 @@ 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<SourceName> &componentNames() const {
return componentNames_;
@ -292,6 +294,7 @@ private:
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 @@ 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,

34
flang/lib/Evaluate/fold-designator.cpp
View File

@ -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;
}

33
flang/lib/Parser/Fortran-parsers.cpp
View File

@ -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>(

46
flang/lib/Parser/unparse.cpp
View File

@ -265,18 +265,25 @@ public:
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 @@ public:
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 @@ public:
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(); }

23
flang/lib/Parser/user-state.cpp
View File

@ -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

23
flang/lib/Semantics/check-data.cpp
View File

@ -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_);
}

4
flang/lib/Semantics/check-data.h
View File

@ -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 <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_;

89
flang/lib/Semantics/data-to-inits.cpp
View File

@ -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 @@ public:
}
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 @@ 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<std::pair<SomeExpr, bool>> ConvertElement(
@ -112,10 +116,12 @@ private:
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) {

6
flang/lib/Semantics/data-to-inits.h
View File

@ -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 &);

126
flang/lib/Semantics/mod-file.cpp
View File

@ -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

15
flang/lib/Semantics/mod-file.h
View File

@ -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 @@ 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<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 &);

171
flang/lib/Semantics/resolve-names.cpp
View File

@ -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<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 @@ 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<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);

5
flang/lib/Semantics/runtime-type-info.cpp
View File

@ -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{

6
flang/lib/Semantics/semantics.cpp
View File

@ -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*/);

9
flang/lib/Semantics/type.cpp
View File

@ -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:

48
flang/test/Semantics/modfile42.f90 Normal file
View File

@ -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

19
flang/test/Semantics/struct01.f90 Normal file
View File

@ -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

24
flang/test/Semantics/symbol15.f90
View File

@ -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)