diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h --- a/flang/include/flang/Evaluate/initial-image.h +++ b/flang/include/flang/Evaluate/initial-image.h @@ -87,6 +87,8 @@ void AddPointer(ConstantSubscript, const Expr &); + void Incorporate(ConstantSubscript, const InitialImage &); + // Conversions to constant initializers std::optional> AsConstant(FoldingContext &, const DynamicType &, const ConstantSubscripts &, diff --git a/flang/include/flang/Parser/parsing.h b/flang/include/flang/Parser/parsing.h --- a/flang/include/flang/Parser/parsing.h +++ b/flang/include/flang/Parser/parsing.h @@ -62,8 +62,6 @@ o, cooked_.GetProvenanceRange(CharBlock(at)), message, echoSourceLine); } - bool ForTesting(std::string path, llvm::raw_ostream &); - private: Options options_; CookedSource cooked_; diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -170,6 +170,7 @@ void ActivateIndexVar(const parser::Name &, IndexVarKind); void DeactivateIndexVar(const parser::Name &); SymbolVector GetIndexVars(IndexVarKind); + SourceName GetTempName(const Scope &); private: void CheckIndexVarRedefine( @@ -196,6 +197,7 @@ IndexVarKind kind; }; std::map activeIndexVars_; + std::vector tempNames_; }; class Semantics { diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -53,7 +53,7 @@ static Bound Assumed() { return Bound(Category::Assumed); } static Bound Deferred() { return Bound(Category::Deferred); } explicit Bound(MaybeSubscriptIntExpr &&expr) : expr_{std::move(expr)} {} - explicit Bound(int bound); + explicit Bound(common::ConstantSubscript bound); Bound(const Bound &) = default; Bound(Bound &&) = default; Bound &operator=(const Bound &) = default; diff --git a/flang/lib/Evaluate/initial-image.cpp b/flang/lib/Evaluate/initial-image.cpp --- a/flang/lib/Evaluate/initial-image.cpp +++ b/flang/lib/Evaluate/initial-image.cpp @@ -9,6 +9,7 @@ #include "flang/Evaluate/initial-image.h" #include "flang/Semantics/scope.h" #include "flang/Semantics/tools.h" +#include namespace Fortran::evaluate { @@ -53,6 +54,13 @@ pointers_.emplace(offset, pointer); } +void InitialImage::Incorporate( + ConstantSubscript offset, const InitialImage &that) { + CHECK(that.pointers_.empty()); // pointers are not allowed in EQUIVALENCE + CHECK(offset + that.size() <= size()); + std::memcpy(&data_[offset], &that.data_[0], that.size()); +} + // Classes used with common::SearchTypes() to (re)construct Constant<> values // of the right type to initialize each symbol from the values that have // been placed into its initialization image by DATA statements. diff --git a/flang/lib/Parser/parsing.cpp b/flang/lib/Parser/parsing.cpp --- a/flang/lib/Parser/parsing.cpp +++ b/flang/lib/Parser/parsing.cpp @@ -123,24 +123,4 @@ void Parsing::ClearLog() { log_.clear(); } -bool Parsing::ForTesting(std::string path, llvm::raw_ostream &err) { - llvm::raw_null_ostream NullStream; - Prescan(path, Options{}); - if (messages_.AnyFatalError()) { - messages_.Emit(err, cooked_); - err << "could not scan " << path << '\n'; - return false; - } - Parse(NullStream); - messages_.Emit(err, cooked_); - if (!consumedWholeFile_) { - EmitMessage(err, finalRestingPlace_, "parser FAIL; final position"); - return false; - } - if (messages_.AnyFatalError() || !parseTree_.has_value()) { - err << "could not parse " << path << '\n'; - return false; - } - return true; -} } // namespace Fortran::parser diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt --- a/flang/lib/Semantics/CMakeLists.txt +++ b/flang/lib/Semantics/CMakeLists.txt @@ -26,6 +26,7 @@ check-select-type.cpp check-stop.cpp compute-offsets.cpp + data-to-inits.cpp expression.cpp mod-file.cpp pointer-assignment.cpp diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h --- a/flang/lib/Semantics/check-data.h +++ b/flang/lib/Semantics/check-data.h @@ -9,6 +9,7 @@ #ifndef FORTRAN_SEMANTICS_CHECK_DATA_H_ #define FORTRAN_SEMANTICS_CHECK_DATA_H_ +#include "data-to-inits.h" #include "flang/Common/interval.h" #include "flang/Evaluate/fold-designator.h" #include "flang/Evaluate/initial-image.h" @@ -28,15 +29,6 @@ namespace Fortran::semantics { -struct SymbolDataInitialization { - using Range = common::Interval; - explicit SymbolDataInitialization(std::size_t bytes) : image{bytes} {} - evaluate::InitialImage image; - std::list inits; -}; - -using DataInitializations = std::map; - class DataChecker : public virtual BaseChecker { public: explicit DataChecker(SemanticsContext &context) : exprAnalyzer_{context} {} @@ -55,7 +47,6 @@ template void CheckIfConstantSubscript(const T &); void CheckSubscript(const parser::SectionSubscript &); bool CheckAllSubscriptsInDataRef(const parser::DataRef &, parser::CharBlock); - void ConstructInitializer(const Symbol &, SymbolDataInitialization &); DataInitializations inits_; evaluate::ExpressionAnalyzer exprAnalyzer_; diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp --- a/flang/lib/Semantics/check-data.cpp +++ b/flang/lib/Semantics/check-data.cpp @@ -9,19 +9,16 @@ // DATA statement semantic analysis. // - Applies static semantic checks to the variables in each data-stmt-set with // class DataVarChecker; -// - Applies specific checks to each scalar element initialization with a -// constant value or pointer tareg with class DataInitializationCompiler; -// - Collects the elemental initializations for each symbol and converts them -// into a single init() expression with member function -// DataChecker::ConstructInitializer(). +// - Invokes conversion of DATA statement values to static initializers #include "check-data.h" -#include "pointer-assignment.h" -#include "flang/Evaluate/fold-designator.h" +#include "data-to-inits.h" #include "flang/Evaluate/traverse.h" #include "flang/Parser/parse-tree.h" #include "flang/Parser/tools.h" #include "flang/Semantics/tools.h" +#include +#include namespace Fortran::semantics { @@ -193,8 +190,8 @@ } } } + currentSetHasFatalErrors_ = true; } - currentSetHasFatalErrors_ = true; } void DataChecker::Leave(const parser::DataStmtObject &dataObject) { @@ -213,434 +210,15 @@ dataObject.u); } -// Steps through a list of values in a DATA statement set; implements -// repetition. -class ValueListIterator { -public: - explicit ValueListIterator(const parser::DataStmtSet &set) - : end_{std::get>(set.t).end()}, - at_{std::get>(set.t).begin()} { - SetRepetitionCount(); - } - bool hasFatalError() const { return hasFatalError_; } - bool IsAtEnd() const { return at_ == end_; } - const SomeExpr *operator*() const { return GetExpr(GetConstant()); } - parser::CharBlock LocateSource() const { return GetConstant().source; } - ValueListIterator &operator++() { - if (repetitionsRemaining_ > 0) { - --repetitionsRemaining_; - } else if (at_ != end_) { - ++at_; - SetRepetitionCount(); - } - return *this; - } - -private: - using listIterator = std::list::const_iterator; - void SetRepetitionCount(); - const parser::DataStmtConstant &GetConstant() const { - return std::get(at_->t); - } - - listIterator end_; - listIterator at_; - ConstantSubscript repetitionsRemaining_{0}; - bool hasFatalError_{false}; -}; - -void ValueListIterator::SetRepetitionCount() { - for (repetitionsRemaining_ = 1; at_ != end_; ++at_) { - if (at_->repetitions < 0) { - hasFatalError_ = true; - } - if (at_->repetitions > 0) { - repetitionsRemaining_ = at_->repetitions - 1; - return; - } - } - repetitionsRemaining_ = 0; -} - -// Collects all of the elemental initializations from DATA statements -// into a single image for each symbol that appears in any DATA. -// 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. -class DataInitializationCompiler { -public: - DataInitializationCompiler(DataInitializations &inits, - evaluate::ExpressionAnalyzer &a, const parser::DataStmtSet &set) - : inits_{inits}, exprAnalyzer_{a}, values_{set} {} - const DataInitializations &inits() const { return inits_; } - bool HasSurplusValues() const { return !values_.IsAtEnd(); } - bool Scan(const parser::DataStmtObject &); - -private: - bool Scan(const parser::Variable &); - bool Scan(const parser::Designator &); - bool Scan(const parser::DataImpliedDo &); - bool Scan(const parser::DataIDoObject &); - - // Initializes all elements of a designator, which can be an array or section. - bool InitDesignator(const SomeExpr &); - // Initializes a single object. - bool InitElement(const evaluate::OffsetSymbol &, const SomeExpr &designator); - // If the returned flag is true, emit a warning about CHARACTER misusage. - std::optional> ConvertElement( - const SomeExpr &, const evaluate::DynamicType &); - - DataInitializations &inits_; - evaluate::ExpressionAnalyzer &exprAnalyzer_; - ValueListIterator values_; -}; - -bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) { - return std::visit( - common::visitors{ - [&](const common::Indirection &var) { - return Scan(var.value()); - }, - [&](const parser::DataImpliedDo &ido) { return Scan(ido); }, - }, - object.u); -} - -bool DataInitializationCompiler::Scan(const parser::Variable &var) { - if (const auto *expr{GetExpr(var)}) { - exprAnalyzer_.GetFoldingContext().messages().SetLocation(var.GetSource()); - if (InitDesignator(*expr)) { - return true; - } - } - return false; -} - -bool DataInitializationCompiler::Scan(const parser::Designator &designator) { - if (auto expr{exprAnalyzer_.Analyze(designator)}) { - exprAnalyzer_.GetFoldingContext().messages().SetLocation( - parser::FindSourceLocation(designator)); - if (InitDesignator(*expr)) { - return true; - } - } - return false; -} - -bool DataInitializationCompiler::Scan(const parser::DataImpliedDo &ido) { - const auto &bounds{std::get(ido.t)}; - auto name{bounds.name.thing.thing}; - const auto *lowerExpr{GetExpr(bounds.lower.thing.thing)}; - const auto *upperExpr{GetExpr(bounds.upper.thing.thing)}; - const auto *stepExpr{ - bounds.step ? GetExpr(bounds.step->thing.thing) : nullptr}; - if (lowerExpr && upperExpr) { - auto lower{ToInt64(*lowerExpr)}; - auto upper{ToInt64(*upperExpr)}; - auto step{stepExpr ? ToInt64(*stepExpr) : std::nullopt}; - auto stepVal{step.value_or(1)}; - if (stepVal == 0) { - exprAnalyzer_.Say(name.source, - "DATA statement implied DO loop has a step value of zero"_err_en_US); - } else if (lower && upper) { - int kind{evaluate::ResultType::kind}; - if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) { - if (dynamicType->category() == TypeCategory::Integer) { - kind = dynamicType->kind(); - } - } - if (exprAnalyzer_.AddImpliedDo(name.source, kind)) { - auto &value{exprAnalyzer_.GetFoldingContext().StartImpliedDo( - name.source, *lower)}; - bool result{true}; - for (auto n{(*upper - value + stepVal) / stepVal}; n > 0; - --n, value += stepVal) { - for (const auto &object : - std::get>(ido.t)) { - if (!Scan(object)) { - result = false; - break; - } - } - } - exprAnalyzer_.GetFoldingContext().EndImpliedDo(name.source); - exprAnalyzer_.RemoveImpliedDo(name.source); - return result; - } - } - } - return false; -} - -bool DataInitializationCompiler::Scan(const parser::DataIDoObject &object) { - return std::visit( - common::visitors{ - [&](const parser::Scalar> - &var) { return Scan(var.thing.value()); }, - [&](const common::Indirection &ido) { - return Scan(ido.value()); - }, - }, - object.u); -} - -bool DataInitializationCompiler::InitDesignator(const SomeExpr &designator) { - evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; - evaluate::DesignatorFolder folder{context}; - while (auto offsetSymbol{folder.FoldDesignator(designator)}) { - if (folder.isOutOfRange()) { - if (auto bad{evaluate::OffsetToDesignator(context, *offsetSymbol)}) { - exprAnalyzer_.context().Say( - "DATA statement designator '%s' is out of range"_err_en_US, - bad->AsFortran()); - } else { - exprAnalyzer_.context().Say( - "DATA statement designator '%s' is out of range"_err_en_US, - designator.AsFortran()); - } - return false; - } else if (!InitElement(*offsetSymbol, designator)) { - return false; - } else { - ++values_; - } - } - return folder.isEmpty(); -} - -std::optional> -DataInitializationCompiler::ConvertElement( - const SomeExpr &expr, const evaluate::DynamicType &type) { - if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) { - return {std::make_pair(std::move(*converted), false)}; - } - if (std::optional chValue{evaluate::GetScalarConstantValue< - evaluate::Type>(expr)}) { - // Allow DATA initialization with Hollerith and kind=1 CHARACTER like - // (most) other Fortran compilers do. Pad on the right with spaces - // when short, truncate the right if long. - // TODO: big-endian targets - std::size_t bytes{type.MeasureSizeInBytes().value()}; - evaluate::BOZLiteralConstant bits{0}; - for (std::size_t j{0}; j < bytes; ++j) { - char ch{j >= chValue->size() ? ' ' : chValue->at(j)}; - evaluate::BOZLiteralConstant chBOZ{static_cast(ch)}; - bits = bits.IOR(chBOZ.SHIFTL(8 * j)); - } - if (auto converted{evaluate::ConvertToType(type, SomeExpr{bits})}) { - return {std::make_pair(std::move(*converted), true)}; - } - } - return std::nullopt; -} - -bool DataInitializationCompiler::InitElement( - const evaluate::OffsetSymbol &offsetSymbol, const SomeExpr &designator) { - const Symbol &symbol{offsetSymbol.symbol()}; - const Symbol *lastSymbol{GetLastSymbol(designator)}; - bool isPointer{lastSymbol && IsPointer(*lastSymbol)}; - bool isProcPointer{lastSymbol && IsProcedurePointer(*lastSymbol)}; - evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; - - const auto DescribeElement{[&]() { - if (auto badDesignator{ - evaluate::OffsetToDesignator(context, offsetSymbol)}) { - return badDesignator->AsFortran(); - } else { - // Error recovery - std::string buf; - llvm::raw_string_ostream ss{buf}; - ss << offsetSymbol.symbol().name() << " offset " << offsetSymbol.offset() - << " bytes for " << offsetSymbol.size() << " bytes"; - return ss.str(); - } - }}; - const auto GetImage{[&]() -> evaluate::InitialImage & { - auto &symbolInit{inits_.emplace(symbol, symbol.size()).first->second}; - symbolInit.inits.emplace_back(offsetSymbol.offset(), offsetSymbol.size()); - return symbolInit.image; - }}; - const auto OutOfRangeError{[&]() { - evaluate::AttachDeclaration( - exprAnalyzer_.context().Say( - "DATA statement designator '%s' is out of range for its variable '%s'"_err_en_US, - DescribeElement(), symbol.name()), - symbol); - }}; - - if (values_.hasFatalError()) { - return false; - } else if (values_.IsAtEnd()) { - exprAnalyzer_.context().Say( - "DATA statement set has no value for '%s'"_err_en_US, - DescribeElement()); - return false; - } else if (static_cast( - offsetSymbol.offset() + offsetSymbol.size()) > symbol.size()) { - OutOfRangeError(); - return false; - } - - const SomeExpr *expr{*values_}; - if (!expr) { - CHECK(exprAnalyzer_.context().AnyFatalError()); - } else if (isPointer) { - if (static_cast(offsetSymbol.offset() + offsetSymbol.size()) > - symbol.size()) { - OutOfRangeError(); - } else if (evaluate::IsNullPointer(*expr)) { - // nothing to do; rely on zero initialization - return true; - } else if (evaluate::IsProcedure(*expr)) { - if (isProcPointer) { - if (CheckPointerAssignment(context, designator, *expr)) { - GetImage().AddPointer(offsetSymbol.offset(), *expr); - return true; - } - } else { - exprAnalyzer_.Say(values_.LocateSource(), - "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, - expr->AsFortran(), DescribeElement()); - } - } else if (isProcPointer) { - exprAnalyzer_.Say(values_.LocateSource(), - "Data object '%s' may not be used to initialize '%s', which is a procedure pointer"_err_en_US, - expr->AsFortran(), DescribeElement()); - } else if (CheckInitialTarget(context, designator, *expr)) { - GetImage().AddPointer(offsetSymbol.offset(), *expr); - return true; - } - } else if (evaluate::IsNullPointer(*expr)) { - exprAnalyzer_.Say(values_.LocateSource(), - "Initializer for '%s' must not be a pointer"_err_en_US, - DescribeElement()); - } else if (evaluate::IsProcedure(*expr)) { - exprAnalyzer_.Say(values_.LocateSource(), - "Initializer for '%s' must not be a procedure"_err_en_US, - DescribeElement()); - } else if (auto designatorType{designator.GetType()}) { - if (auto converted{ConvertElement(*expr, *designatorType)}) { - // value non-pointer initialization - if (std::holds_alternative(expr->u) && - designatorType->category() != TypeCategory::Integer) { // 8.6.7(11) - exprAnalyzer_.Say(values_.LocateSource(), - "BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_en_US, - DescribeElement(), designatorType->AsFortran()); - } else if (converted->second) { - exprAnalyzer_.context().Say( - "DATA statement value initializes '%s' of type '%s' with CHARACTER"_en_US, - DescribeElement(), designatorType->AsFortran()); - } - auto folded{evaluate::Fold(context, std::move(converted->first))}; - switch ( - GetImage().Add(offsetSymbol.offset(), offsetSymbol.size(), folded)) { - case evaluate::InitialImage::Ok: - return true; - case evaluate::InitialImage::NotAConstant: - exprAnalyzer_.Say(values_.LocateSource(), - "DATA statement value '%s' for '%s' is not a constant"_err_en_US, - folded.AsFortran(), DescribeElement()); - break; - case evaluate::InitialImage::OutOfRange: - OutOfRangeError(); - break; - default: - CHECK(exprAnalyzer_.context().AnyFatalError()); - break; - } - } else { - exprAnalyzer_.context().Say( - "DATA statement value could not be converted to the type '%s' of the object '%s'"_err_en_US, - designatorType->AsFortran(), DescribeElement()); - } - } else { - CHECK(exprAnalyzer_.context().AnyFatalError()); - } - return false; -} - void DataChecker::Leave(const parser::DataStmtSet &set) { if (!currentSetHasFatalErrors_) { - DataInitializationCompiler scanner{inits_, exprAnalyzer_, set}; - for (const auto &object : - std::get>(set.t)) { - if (!scanner.Scan(object)) { - return; - } - } - if (scanner.HasSurplusValues()) { - exprAnalyzer_.context().Say( - "DATA statement set has more values than objects"_err_en_US); - } + AccumulateDataInitializations(inits_, exprAnalyzer_, set); } currentSetHasFatalErrors_ = false; } -// Converts the initialization image for all the DATA statement appearances of -// a single symbol into an init() expression in the symbol table entry. -void DataChecker::ConstructInitializer( - const Symbol &symbol, SymbolDataInitialization &initialization) { - auto &context{exprAnalyzer_.GetFoldingContext()}; - initialization.inits.sort(); - ConstantSubscript next{0}; - for (const auto &init : initialization.inits) { - if (init.start() < next) { - auto badDesignator{evaluate::OffsetToDesignator( - context, symbol, init.start(), init.size())}; - CHECK(badDesignator); - exprAnalyzer_.Say(symbol.name(), - "DATA statement initializations affect '%s' more than once"_err_en_US, - badDesignator->AsFortran()); - } - next = init.start() + init.size(); - CHECK(next <= static_cast(initialization.image.size())); - } - if (const auto *proc{symbol.detailsIf()}) { - CHECK(IsProcedurePointer(symbol)); - const auto &procDesignator{initialization.image.AsConstantProcPointer()}; - CHECK(!procDesignator.GetComponent()); - auto &mutableProc{const_cast(*proc)}; - mutableProc.set_init(DEREF(procDesignator.GetSymbol())); - } else if (const auto *object{symbol.detailsIf()}) { - if (auto symbolType{evaluate::DynamicType::From(symbol)}) { - auto &mutableObject{const_cast(*object)}; - if (IsPointer(symbol)) { - mutableObject.set_init( - initialization.image.AsConstantDataPointer(*symbolType)); - mutableObject.set_initWasValidated(); - } else { - if (auto extents{evaluate::GetConstantExtents(context, symbol)}) { - mutableObject.set_init( - initialization.image.AsConstant(context, *symbolType, *extents)); - mutableObject.set_initWasValidated(); - } else { - exprAnalyzer_.Say(symbol.name(), - "internal: unknown shape for '%s' while constructing initializer from DATA"_err_en_US, - symbol.name()); - return; - } - } - } else { - exprAnalyzer_.Say(symbol.name(), - "internal: no type for '%s' while constructing initializer from DATA"_err_en_US, - symbol.name()); - return; - } - if (!object->init()) { - exprAnalyzer_.Say(symbol.name(), - "internal: could not construct an initializer from DATA statements for '%s'"_err_en_US, - symbol.name()); - } - } else { - CHECK(exprAnalyzer_.context().AnyFatalError()); - } -} - void DataChecker::CompileDataInitializationsIntoInitializers() { - for (auto &[symbolRef, initialization] : inits_) { - ConstructInitializer(*symbolRef, initialization); - } + ConvertToInitializers(inits_, exprAnalyzer_); } } // namespace Fortran::semantics diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp --- a/flang/lib/Semantics/compute-offsets.cpp +++ b/flang/lib/Semantics/compute-offsets.cpp @@ -51,6 +51,7 @@ void Compute(Scope &); void DoScope(Scope &); void DoCommonBlock(Symbol &); + void DoEquivalenceBlockBase(Symbol &, SizeAndAlignment &); void DoEquivalenceSet(const EquivalenceSet &); SymbolAndOffset Resolve(const SymbolAndOffset &); std::size_t ComputeOffset(const EquivalenceObject &); @@ -67,6 +68,8 @@ std::size_t alignment_{0}; // symbol -> symbol+offset that determines its location, from EQUIVALENCE std::map dependents_; + // base symbol -> SizeAndAlignment for each distinct EQUIVALENCE block + std::map equivalenceBlock_; }; void ComputeOffsetsHelper::Compute(Scope &scope) { @@ -74,6 +77,8 @@ Compute(child); } DoScope(scope); + dependents_.clear(); + equivalenceBlock_.clear(); } static bool InCommonBlock(const Symbol &symbol) { @@ -85,33 +90,60 @@ if (scope.symbol() && scope.IsParameterizedDerivedType()) { return; // only process instantiations of parameterized derived types } - // Symbols in common block get offsets from the beginning of the block - for (auto &pair : scope.commonBlocks()) { - DoCommonBlock(*pair.second); - } // Build dependents_ from equivalences: symbol -> symbol+offset for (const EquivalenceSet &set : scope.equivalenceSets()) { DoEquivalenceSet(set); } offset_ = 0; alignment_ = 0; + // Compute a base symbol and overall block size for each + // disjoint EQUIVALENCE storage sequence. + for (auto &[symbol, dep] : dependents_) { + dep = Resolve(dep); + CHECK(symbol->size() == 0); + auto symInfo{GetSizeAndAlignment(*symbol)}; + symbol->set_size(symInfo.size); + Symbol &base{*dep.symbol}; + auto iter{equivalenceBlock_.find(base)}; + std::size_t minBlockSize{dep.offset + symInfo.size}; + if (iter == equivalenceBlock_.end()) { + equivalenceBlock_.emplace( + base, SizeAndAlignment{minBlockSize, symInfo.alignment}); + } else { + SizeAndAlignment &blockInfo{iter->second}; + blockInfo.size = std::max(blockInfo.size, minBlockSize); + blockInfo.alignment = std::max(blockInfo.alignment, symInfo.alignment); + } + } + // Assign offsets for non-COMMON EQUIVALENCE blocks + for (auto &[symbol, blockInfo] : equivalenceBlock_) { + if (!InCommonBlock(*symbol)) { + DoSymbol(*symbol); + DoEquivalenceBlockBase(*symbol, blockInfo); + offset_ = std::max(offset_, symbol->offset() + blockInfo.size); + } + } + // Process remaining non-COMMON symbols; this is all of them if there + // was no use of EQUIVALENCE in the scope. for (auto &symbol : scope.GetSymbols()) { if (!InCommonBlock(*symbol) && - dependents_.find(symbol) == dependents_.end()) { + dependents_.find(symbol) == dependents_.end() && + equivalenceBlock_.find(symbol) == equivalenceBlock_.end()) { DoSymbol(*symbol); } } + scope.set_size(offset_); + scope.set_alignment(alignment_); + // Assign offsets in COMMON blocks. + for (auto &pair : scope.commonBlocks()) { + DoCommonBlock(*pair.second); + } for (auto &[symbol, dep] : dependents_) { - if (symbol->size() == 0) { - SizeAndAlignment s{GetSizeAndAlignment(*symbol)}; - symbol->set_size(s.size); - SymbolAndOffset resolved{Resolve(dep)}; - symbol->set_offset(dep.symbol->offset() + resolved.offset); - offset_ = std::max(offset_, symbol->offset() + symbol->size()); + symbol->set_offset(dep.symbol->offset() + dep.offset); + if (const auto *block{FindCommonBlockContaining(*dep.symbol)}) { + symbol->get().set_commonBlock(*block); } } - scope.set_size(offset_); - scope.set_alignment(alignment_); } auto ComputeOffsetsHelper::Resolve(const SymbolAndOffset &dep) @@ -131,11 +163,57 @@ auto &details{commonBlock.get()}; offset_ = 0; alignment_ = 0; + std::size_t minSize{0}; + std::size_t minAlignment{0}; for (auto &object : details.objects()) { - DoSymbol(*object); + Symbol &symbol{*object}; + DoSymbol(symbol); + auto iter{dependents_.find(symbol)}; + if (iter == dependents_.end()) { + // Get full extent of any EQUIVALENCE block into size of COMMON + auto eqIter{equivalenceBlock_.find(symbol)}; + if (eqIter != equivalenceBlock_.end()) { + SizeAndAlignment &blockInfo{eqIter->second}; + DoEquivalenceBlockBase(symbol, blockInfo); + minSize = std::max( + minSize, std::max(offset_, symbol.offset() + blockInfo.size)); + minAlignment = std::max(minAlignment, blockInfo.alignment); + } + } else { + SymbolAndOffset &dep{iter->second}; + Symbol &base{*dep.symbol}; + auto errorSite{ + commonBlock.name().empty() ? symbol.name() : commonBlock.name()}; + if (const auto *baseBlock{FindCommonBlockContaining(base)}) { + if (baseBlock == &commonBlock) { + context_.Say(errorSite, + "'%s' is storage associated with '%s' by EQUIVALENCE elsewhere in COMMON block /%s/"_err_en_US, + symbol.name(), base.name(), commonBlock.name()); + } else { // 8.10.3(1) + context_.Say(errorSite, + "'%s' in COMMON block /%s/ must not be storage associated with '%s' in COMMON block /%s/ by EQUIVALENCE"_err_en_US, + symbol.name(), commonBlock.name(), base.name(), + baseBlock->name()); + } + } else if (dep.offset > symbol.offset()) { // 8.10.3(3) + context_.Say(errorSite, + "'%s' cannot backward-extend COMMON block /%s/ via EQUIVALENCE with '%s'"_err_en_US, + symbol.name(), commonBlock.name(), base.name()); + } else { + base.get().set_commonBlock(commonBlock); + base.set_offset(symbol.offset() - dep.offset); + } + } + } + commonBlock.set_size(std::max(minSize, offset_)); + details.set_alignment(std::max(minAlignment, alignment_)); +} + +void ComputeOffsetsHelper::DoEquivalenceBlockBase( + Symbol &symbol, SizeAndAlignment &blockInfo) { + if (symbol.size() > blockInfo.size) { + blockInfo.size = symbol.size(); } - commonBlock.set_size(offset_); - details.set_alignment(alignment_); } void ComputeOffsetsHelper::DoEquivalenceSet(const EquivalenceSet &set) { diff --git a/flang/lib/Semantics/data-to-inits.h b/flang/lib/Semantics/data-to-inits.h new file mode 100644 --- /dev/null +++ b/flang/lib/Semantics/data-to-inits.h @@ -0,0 +1,46 @@ +//===-- lib/Semantics/data-to-inits.h -------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_SEMANTICS_DATA_TO_INITS_H_ +#define FORTRAN_SEMANTICS_DATA_TO_INITS_H_ + +#include "flang/Common/default-kinds.h" +#include "flang/Common/interval.h" +#include "flang/Evaluate/initial-image.h" +#include +#include + +namespace Fortran::parser { +class DataStmtSet; +} +namespace Fortran::evaluate { +class ExpressionAnalyzer; +} +namespace Fortran::semantics { + +class Symbol; + +struct SymbolDataInitialization { + using Range = common::Interval; + explicit SymbolDataInitialization(std::size_t bytes) : image{bytes} {} + evaluate::InitialImage image; + std::list inits; +}; + +using DataInitializations = std::map; + +// Matches DATA statement variables with their values and checks +// compatibility. +void AccumulateDataInitializations(DataInitializations &, + evaluate::ExpressionAnalyzer &, const parser::DataStmtSet &); + +void ConvertToInitializers( + DataInitializations &, evaluate::ExpressionAnalyzer &); + +} // namespace Fortran::semantics +#endif // FORTRAN_SEMANTICS_DATA_TO_INITS_H_ diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -0,0 +1,550 @@ +//===-- lib/Semantics/data-to-inits.cpp -----------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// DATA statement object/value checking and conversion to static +// initializers +// - Applies specific checks to each scalar element initialization with a +// constant value or pointer target with class DataInitializationCompiler; +// - Collects the elemental initializations for each symbol and converts them +// into a single init() expression with member function +// DataChecker::ConstructInitializer(). + +#include "data-to-inits.h" +#include "pointer-assignment.h" +#include "flang/Evaluate/fold-designator.h" +#include "flang/Semantics/tools.h" + +namespace Fortran::semantics { + +// Steps through a list of values in a DATA statement set; implements +// repetition. +class ValueListIterator { +public: + explicit ValueListIterator(const parser::DataStmtSet &set) + : end_{std::get>(set.t).end()}, + at_{std::get>(set.t).begin()} { + SetRepetitionCount(); + } + bool hasFatalError() const { return hasFatalError_; } + bool IsAtEnd() const { return at_ == end_; } + const SomeExpr *operator*() const { return GetExpr(GetConstant()); } + parser::CharBlock LocateSource() const { return GetConstant().source; } + ValueListIterator &operator++() { + if (repetitionsRemaining_ > 0) { + --repetitionsRemaining_; + } else if (at_ != end_) { + ++at_; + SetRepetitionCount(); + } + return *this; + } + +private: + using listIterator = std::list::const_iterator; + void SetRepetitionCount(); + const parser::DataStmtConstant &GetConstant() const { + return std::get(at_->t); + } + + listIterator end_; + listIterator at_; + ConstantSubscript repetitionsRemaining_{0}; + bool hasFatalError_{false}; +}; + +void ValueListIterator::SetRepetitionCount() { + for (repetitionsRemaining_ = 1; at_ != end_; ++at_) { + if (at_->repetitions < 0) { + hasFatalError_ = true; + } + if (at_->repetitions > 0) { + repetitionsRemaining_ = at_->repetitions - 1; + return; + } + } + repetitionsRemaining_ = 0; +} + +// Collects all of the elemental initializations from DATA statements +// into a single image for each symbol that appears in any DATA. +// 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. +class DataInitializationCompiler { +public: + DataInitializationCompiler(DataInitializations &inits, + evaluate::ExpressionAnalyzer &a, const parser::DataStmtSet &set) + : inits_{inits}, exprAnalyzer_{a}, values_{set} {} + const DataInitializations &inits() const { return inits_; } + bool HasSurplusValues() const { return !values_.IsAtEnd(); } + bool Scan(const parser::DataStmtObject &); + +private: + bool Scan(const parser::Variable &); + bool Scan(const parser::Designator &); + bool Scan(const parser::DataImpliedDo &); + bool Scan(const parser::DataIDoObject &); + + // Initializes all elements of a designator, which can be an array or section. + bool InitDesignator(const SomeExpr &); + // Initializes a single object. + bool InitElement(const evaluate::OffsetSymbol &, const SomeExpr &designator); + // If the returned flag is true, emit a warning about CHARACTER misusage. + std::optional> ConvertElement( + const SomeExpr &, const evaluate::DynamicType &); + + DataInitializations &inits_; + evaluate::ExpressionAnalyzer &exprAnalyzer_; + ValueListIterator values_; +}; + +bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) { + return std::visit( + common::visitors{ + [&](const common::Indirection &var) { + return Scan(var.value()); + }, + [&](const parser::DataImpliedDo &ido) { return Scan(ido); }, + }, + object.u); +} + +bool DataInitializationCompiler::Scan(const parser::Variable &var) { + if (const auto *expr{GetExpr(var)}) { + exprAnalyzer_.GetFoldingContext().messages().SetLocation(var.GetSource()); + if (InitDesignator(*expr)) { + return true; + } + } + return false; +} + +bool DataInitializationCompiler::Scan(const parser::Designator &designator) { + if (auto expr{exprAnalyzer_.Analyze(designator)}) { + exprAnalyzer_.GetFoldingContext().messages().SetLocation( + parser::FindSourceLocation(designator)); + if (InitDesignator(*expr)) { + return true; + } + } + return false; +} + +bool DataInitializationCompiler::Scan(const parser::DataImpliedDo &ido) { + const auto &bounds{std::get(ido.t)}; + auto name{bounds.name.thing.thing}; + const auto *lowerExpr{GetExpr(bounds.lower.thing.thing)}; + const auto *upperExpr{GetExpr(bounds.upper.thing.thing)}; + const auto *stepExpr{ + bounds.step ? GetExpr(bounds.step->thing.thing) : nullptr}; + if (lowerExpr && upperExpr) { + auto lower{ToInt64(*lowerExpr)}; + auto upper{ToInt64(*upperExpr)}; + auto step{stepExpr ? ToInt64(*stepExpr) : std::nullopt}; + auto stepVal{step.value_or(1)}; + if (stepVal == 0) { + exprAnalyzer_.Say(name.source, + "DATA statement implied DO loop has a step value of zero"_err_en_US); + } else if (lower && upper) { + int kind{evaluate::ResultType::kind}; + if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) { + if (dynamicType->category() == TypeCategory::Integer) { + kind = dynamicType->kind(); + } + } + if (exprAnalyzer_.AddImpliedDo(name.source, kind)) { + auto &value{exprAnalyzer_.GetFoldingContext().StartImpliedDo( + name.source, *lower)}; + bool result{true}; + for (auto n{(*upper - value + stepVal) / stepVal}; n > 0; + --n, value += stepVal) { + for (const auto &object : + std::get>(ido.t)) { + if (!Scan(object)) { + result = false; + break; + } + } + } + exprAnalyzer_.GetFoldingContext().EndImpliedDo(name.source); + exprAnalyzer_.RemoveImpliedDo(name.source); + return result; + } + } + } + return false; +} + +bool DataInitializationCompiler::Scan(const parser::DataIDoObject &object) { + return std::visit( + common::visitors{ + [&](const parser::Scalar> + &var) { return Scan(var.thing.value()); }, + [&](const common::Indirection &ido) { + return Scan(ido.value()); + }, + }, + object.u); +} + +bool DataInitializationCompiler::InitDesignator(const SomeExpr &designator) { + evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; + evaluate::DesignatorFolder folder{context}; + while (auto offsetSymbol{folder.FoldDesignator(designator)}) { + if (folder.isOutOfRange()) { + if (auto bad{evaluate::OffsetToDesignator(context, *offsetSymbol)}) { + exprAnalyzer_.context().Say( + "DATA statement designator '%s' is out of range"_err_en_US, + bad->AsFortran()); + } else { + exprAnalyzer_.context().Say( + "DATA statement designator '%s' is out of range"_err_en_US, + designator.AsFortran()); + } + return false; + } else if (!InitElement(*offsetSymbol, designator)) { + return false; + } else { + ++values_; + } + } + return folder.isEmpty(); +} + +std::optional> +DataInitializationCompiler::ConvertElement( + const SomeExpr &expr, const evaluate::DynamicType &type) { + if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) { + return {std::make_pair(std::move(*converted), false)}; + } + if (std::optional chValue{evaluate::GetScalarConstantValue< + evaluate::Type>(expr)}) { + // Allow DATA initialization with Hollerith and kind=1 CHARACTER like + // (most) other Fortran compilers do. Pad on the right with spaces + // when short, truncate the right if long. + // TODO: big-endian targets + std::size_t bytes{type.MeasureSizeInBytes().value()}; + evaluate::BOZLiteralConstant bits{0}; + for (std::size_t j{0}; j < bytes; ++j) { + char ch{j >= chValue->size() ? ' ' : chValue->at(j)}; + evaluate::BOZLiteralConstant chBOZ{static_cast(ch)}; + bits = bits.IOR(chBOZ.SHIFTL(8 * j)); + } + if (auto converted{evaluate::ConvertToType(type, SomeExpr{bits})}) { + return {std::make_pair(std::move(*converted), true)}; + } + } + return std::nullopt; +} + +bool DataInitializationCompiler::InitElement( + const evaluate::OffsetSymbol &offsetSymbol, const SomeExpr &designator) { + const Symbol &symbol{offsetSymbol.symbol()}; + const Symbol *lastSymbol{GetLastSymbol(designator)}; + bool isPointer{lastSymbol && IsPointer(*lastSymbol)}; + bool isProcPointer{lastSymbol && IsProcedurePointer(*lastSymbol)}; + evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; + + const auto DescribeElement{[&]() { + if (auto badDesignator{ + evaluate::OffsetToDesignator(context, offsetSymbol)}) { + return badDesignator->AsFortran(); + } else { + // Error recovery + std::string buf; + llvm::raw_string_ostream ss{buf}; + ss << offsetSymbol.symbol().name() << " offset " << offsetSymbol.offset() + << " bytes for " << offsetSymbol.size() << " bytes"; + return ss.str(); + } + }}; + const auto GetImage{[&]() -> evaluate::InitialImage & { + auto &symbolInit{inits_.emplace(&symbol, symbol.size()).first->second}; + symbolInit.inits.emplace_back(offsetSymbol.offset(), offsetSymbol.size()); + return symbolInit.image; + }}; + const auto OutOfRangeError{[&]() { + evaluate::AttachDeclaration( + exprAnalyzer_.context().Say( + "DATA statement designator '%s' is out of range for its variable '%s'"_err_en_US, + DescribeElement(), symbol.name()), + symbol); + }}; + + if (values_.hasFatalError()) { + return false; + } else if (values_.IsAtEnd()) { + exprAnalyzer_.context().Say( + "DATA statement set has no value for '%s'"_err_en_US, + DescribeElement()); + return false; + } else if (static_cast( + offsetSymbol.offset() + offsetSymbol.size()) > symbol.size()) { + OutOfRangeError(); + return false; + } + + const SomeExpr *expr{*values_}; + if (!expr) { + CHECK(exprAnalyzer_.context().AnyFatalError()); + } else if (isPointer) { + if (static_cast(offsetSymbol.offset() + offsetSymbol.size()) > + symbol.size()) { + OutOfRangeError(); + } else if (evaluate::IsNullPointer(*expr)) { + // nothing to do; rely on zero initialization + return true; + } else if (evaluate::IsProcedure(*expr)) { + if (isProcPointer) { + if (CheckPointerAssignment(context, designator, *expr)) { + GetImage().AddPointer(offsetSymbol.offset(), *expr); + return true; + } + } else { + exprAnalyzer_.Say(values_.LocateSource(), + "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, + expr->AsFortran(), DescribeElement()); + } + } else if (isProcPointer) { + exprAnalyzer_.Say(values_.LocateSource(), + "Data object '%s' may not be used to initialize '%s', which is a procedure pointer"_err_en_US, + expr->AsFortran(), DescribeElement()); + } else if (CheckInitialTarget(context, designator, *expr)) { + GetImage().AddPointer(offsetSymbol.offset(), *expr); + return true; + } + } else if (evaluate::IsNullPointer(*expr)) { + exprAnalyzer_.Say(values_.LocateSource(), + "Initializer for '%s' must not be a pointer"_err_en_US, + DescribeElement()); + } else if (evaluate::IsProcedure(*expr)) { + exprAnalyzer_.Say(values_.LocateSource(), + "Initializer for '%s' must not be a procedure"_err_en_US, + DescribeElement()); + } else if (auto designatorType{designator.GetType()}) { + if (auto converted{ConvertElement(*expr, *designatorType)}) { + // value non-pointer initialization + if (std::holds_alternative(expr->u) && + designatorType->category() != TypeCategory::Integer) { // 8.6.7(11) + exprAnalyzer_.Say(values_.LocateSource(), + "BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_en_US, + DescribeElement(), designatorType->AsFortran()); + } else if (converted->second) { + exprAnalyzer_.context().Say( + "DATA statement value initializes '%s' of type '%s' with CHARACTER"_en_US, + DescribeElement(), designatorType->AsFortran()); + } + auto folded{evaluate::Fold(context, std::move(converted->first))}; + switch ( + GetImage().Add(offsetSymbol.offset(), offsetSymbol.size(), folded)) { + case evaluate::InitialImage::Ok: + return true; + case evaluate::InitialImage::NotAConstant: + exprAnalyzer_.Say(values_.LocateSource(), + "DATA statement value '%s' for '%s' is not a constant"_err_en_US, + folded.AsFortran(), DescribeElement()); + break; + case evaluate::InitialImage::OutOfRange: + OutOfRangeError(); + break; + default: + CHECK(exprAnalyzer_.context().AnyFatalError()); + break; + } + } else { + exprAnalyzer_.context().Say( + "DATA statement value could not be converted to the type '%s' of the object '%s'"_err_en_US, + designatorType->AsFortran(), DescribeElement()); + } + } else { + CHECK(exprAnalyzer_.context().AnyFatalError()); + } + return false; +} + +void AccumulateDataInitializations(DataInitializations &inits, + evaluate::ExpressionAnalyzer &exprAnalyzer, + const parser::DataStmtSet &set) { + DataInitializationCompiler scanner{inits, exprAnalyzer, set}; + for (const auto &object : + std::get>(set.t)) { + if (!scanner.Scan(object)) { + return; + } + } + if (scanner.HasSurplusValues()) { + exprAnalyzer.context().Say( + "DATA statement set has more values than objects"_err_en_US); + } +} + +static bool CombineSomeEquivalencedInits( + DataInitializations &inits, evaluate::ExpressionAnalyzer &exprAnalyzer) { + auto end{inits.end()}; + for (auto iter{inits.begin()}; iter != end; ++iter) { + const Symbol &symbol{*iter->first}; + Scope &scope{const_cast(symbol.owner())}; + if (scope.equivalenceSets().empty()) { + continue; // no problem to solve here + } + const auto *commonBlock{FindCommonBlockContaining(symbol)}; + // Sweep following DATA initializations in search of overlapping + // objects, accumulating into a vector; iterate to a fixed point. + std::vector conflicts; + auto minStart{symbol.offset()}; + auto maxEnd{symbol.offset() + symbol.size()}; + std::size_t minElementBytes{1}; + while (true) { + auto prevCount{conflicts.size()}; + conflicts.clear(); + for (auto scan{iter}; ++scan != end;) { + const Symbol &other{*scan->first}; + const Scope &otherScope{other.owner()}; + if (&otherScope == &scope && + FindCommonBlockContaining(other) == commonBlock && + maxEnd > other.offset() && + other.offset() + other.size() > minStart) { + // "other" conflicts with "symbol" or another conflict + conflicts.push_back(&other); + minStart = std::min(minStart, other.offset()); + maxEnd = std::max(maxEnd, other.offset() + other.size()); + } + } + if (conflicts.size() == prevCount) { + break; + } + } + if (conflicts.empty()) { + continue; + } + // Compute the minimum common granularity + if (auto dyType{evaluate::DynamicType::From(symbol)}) { + minElementBytes = dyType->MeasureSizeInBytes().value_or(1); + } + for (const Symbol *s : conflicts) { + if (auto dyType{evaluate::DynamicType::From(*s)}) { + minElementBytes = + std::min(minElementBytes, dyType->MeasureSizeInBytes().value_or(1)); + } else { + minElementBytes = 1; + } + } + CHECK(minElementBytes > 0); + CHECK((minElementBytes & (minElementBytes - 1)) == 0); + auto bytes{static_cast(maxEnd - minStart)}; + CHECK(bytes % minElementBytes == 0); + const DeclTypeSpec &typeSpec{scope.MakeNumericType( + TypeCategory::Integer, KindExpr{minElementBytes})}; + // Combine "symbol" and "conflicts[]" into a compiler array temp + // that overlaps all of them, and merge their initial values into + // the temp's initializer. + SourceName name{exprAnalyzer.context().GetTempName(scope)}; + auto emplaced{ + scope.try_emplace(name, Attrs{Attr::SAVE}, ObjectEntityDetails{})}; + CHECK(emplaced.second); + Symbol &combinedSymbol{*emplaced.first->second}; + auto &details{combinedSymbol.get()}; + combinedSymbol.set_offset(minStart); + combinedSymbol.set_size(bytes); + details.set_type(typeSpec); + ArraySpec arraySpec; + arraySpec.emplace_back(ShapeSpec::MakeExplicit(Bound{ + bytes / static_cast(minElementBytes)})); + details.set_shape(arraySpec); + if (commonBlock) { + details.set_commonBlock(*commonBlock); + } + // Merge these EQUIVALENCE'd DATA initializations, and remove the + // original initializations from the map. + auto combinedInit{ + inits.emplace(&combinedSymbol, static_cast(bytes))}; + evaluate::InitialImage &combined{combinedInit.first->second.image}; + combined.Incorporate(symbol.offset() - minStart, iter->second.image); + inits.erase(iter); + for (const Symbol *s : conflicts) { + auto sIter{inits.find(s)}; + CHECK(sIter != inits.end()); + combined.Incorporate(s->offset() - minStart, sIter->second.image); + inits.erase(sIter); + } + return true; // got one + } + return false; // no remaining EQUIVALENCE'd DATA initializations +} + +// Converts the initialization image for all the DATA statement appearances of +// a single symbol into an init() expression in the symbol table entry. +void ConstructInitializer(const Symbol &symbol, + SymbolDataInitialization &initialization, + evaluate::ExpressionAnalyzer &exprAnalyzer) { + auto &context{exprAnalyzer.GetFoldingContext()}; + initialization.inits.sort(); + ConstantSubscript next{0}; + for (const auto &init : initialization.inits) { + if (init.start() < next) { + auto badDesignator{evaluate::OffsetToDesignator( + context, symbol, init.start(), init.size())}; + CHECK(badDesignator); + exprAnalyzer.Say(symbol.name(), + "DATA statement initializations affect '%s' more than once"_err_en_US, + badDesignator->AsFortran()); + } + next = init.start() + init.size(); + CHECK(next <= static_cast(initialization.image.size())); + } + if (const auto *proc{symbol.detailsIf()}) { + CHECK(IsProcedurePointer(symbol)); + const auto &procDesignator{initialization.image.AsConstantProcPointer()}; + CHECK(!procDesignator.GetComponent()); + auto &mutableProc{const_cast(*proc)}; + mutableProc.set_init(DEREF(procDesignator.GetSymbol())); + } else if (const auto *object{symbol.detailsIf()}) { + if (auto symbolType{evaluate::DynamicType::From(symbol)}) { + auto &mutableObject{const_cast(*object)}; + if (IsPointer(symbol)) { + mutableObject.set_init( + initialization.image.AsConstantDataPointer(*symbolType)); + mutableObject.set_initWasValidated(); + } else { + if (auto extents{evaluate::GetConstantExtents(context, symbol)}) { + mutableObject.set_init( + initialization.image.AsConstant(context, *symbolType, *extents)); + mutableObject.set_initWasValidated(); + } else { + exprAnalyzer.Say(symbol.name(), + "internal: unknown shape for '%s' while constructing initializer from DATA"_err_en_US, + symbol.name()); + return; + } + } + } else { + exprAnalyzer.Say(symbol.name(), + "internal: no type for '%s' while constructing initializer from DATA"_err_en_US, + symbol.name()); + return; + } + if (!object->init()) { + exprAnalyzer.Say(symbol.name(), + "internal: could not construct an initializer from DATA statements for '%s'"_err_en_US, + symbol.name()); + } + } else { + CHECK(exprAnalyzer.context().AnyFatalError()); + } +} + +void ConvertToInitializers( + DataInitializations &inits, evaluate::ExpressionAnalyzer &exprAnalyzer) { + while (CombineSomeEquivalencedInits(inits, exprAnalyzer)) { + } + for (auto &[symbolPtr, initialization] : inits) { + ConstructInitializer(*symbolPtr, initialization, exprAnalyzer); + } +} +} // namespace Fortran::semantics diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -324,6 +324,18 @@ return result; } +SourceName SemanticsContext::GetTempName(const Scope &scope) { + for (const auto &str : tempNames_) { + SourceName name{str}; + if (scope.find(name) == scope.end()) { + return name; + } + } + tempNames_.emplace_back(".F18."); + tempNames_.back() += std::to_string(tempNames_.size()); + return {tempNames_.back()}; +} + bool Semantics::Perform() { return ValidateLabels(context_, program_) && parser::CanonicalizeDo(program_) && // force line break diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -439,7 +439,7 @@ return o << x.AsFortran(); } -Bound::Bound(int bound) : expr_{bound} {} +Bound::Bound(common::ConstantSubscript bound) : expr_{bound} {} llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const Bound &x) { if (x.isAssumed()) { diff --git a/flang/test/Semantics/block-data01.f90 b/flang/test/Semantics/block-data01.f90 --- a/flang/test/Semantics/block-data01.f90 +++ b/flang/test/Semantics/block-data01.f90 @@ -14,12 +14,20 @@ !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block integer :: inDataButNotCommon data inDataButNotCommon /1/ - !ERROR: Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks integer :: inCommonA, inCommonB + !ERROR: 'incommona' in COMMON block /a/ must not be storage associated with 'incommonb' in COMMON block /b/ by EQUIVALENCE common /a/ inCommonA, /b/ inCommonB equivalence(inCommonA, inCommonB) integer :: inCommonD, initialized ! ok common /d/ inCommonD equivalence(inCommonD, initialized) data initialized /2/ + integer :: inCommonE, jarr(2) + equivalence(inCommonE, jarr(2)) + !ERROR: 'incommone' cannot backward-extend COMMON block /e/ via EQUIVALENCE with 'jarr' + common /e/ inCommonE + equivalence(inCommonF1, inCommonF2) + integer :: inCommonF1, inCommonF2 + !ERROR: 'incommonf1' is storage associated with 'incommonf2' by EQUIVALENCE elsewhere in COMMON block /f/ + common /f/ inCommonF1, inCommonF2 end block data diff --git a/flang/test/Semantics/data09.f90 b/flang/test/Semantics/data09.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/data09.f90 @@ -0,0 +1,9 @@ +! RUN: %f18 -fparse-only -fdebug-dump-symbols %s 2>&1 | FileCheck %s +! CHECK: init:[INTEGER(4)::1065353216_4,1073741824_4,1077936128_4,1082130432_4] +! Verify that the closure of EQUIVALENCE'd symbols with any DATA +! initialization produces a combined initializer. +real :: a(2), b(2), c(2) +equivalence(a(2),b(1)),(b(2),c(1)) +data a(1)/1./,b(1)/2./,c/3.,4./ +common /block/ a +end