[flang-commits] [flang] 4ac617f - [flang] Handle DATA initialization of EQUIVALENCE'd objects
peter klausler via flang-commits
flang-commits at lists.llvm.org
Fri Aug 7 16:39:42 PDT 2020
Author: peter klausler
Date: 2020-08-07T16:39:23-07:00
New Revision: 4ac617f490cde190a893ebe24a60a4e1b1b468d1
URL: https://github.com/llvm/llvm-project/commit/4ac617f490cde190a893ebe24a60a4e1b1b468d1
DIFF: https://github.com/llvm/llvm-project/commit/4ac617f490cde190a893ebe24a60a4e1b1b468d1.diff
LOG: [flang] Handle DATA initialization of EQUIVALENCE'd objects
Objects that are storage associated by EQUIVALENCE and
initialized with DATA are initialized by creating a
compiler temporary data object in the same scope,
assigning it an offset, type, and size that covers the
transitive closure of the associated initialized original
symbols, and combining their initializers into one common
initializer for the temporary.
Some problems with offset assignment of EQUIVALENCE'd objects
in COMMON were exposed and corrected, and some more error
cases are checked.
Remove obsolete function.
Small bugfix (nested implied dos).
Add a test.
Fix struct/class warning.
Differential Revision: https://reviews.llvm.org/D85560
Added:
flang/lib/Semantics/data-to-inits.cpp
flang/lib/Semantics/data-to-inits.h
flang/test/Semantics/data09.f90
Modified:
flang/include/flang/Evaluate/initial-image.h
flang/include/flang/Parser/parsing.h
flang/include/flang/Semantics/semantics.h
flang/include/flang/Semantics/type.h
flang/lib/Evaluate/initial-image.cpp
flang/lib/Parser/parsing.cpp
flang/lib/Semantics/CMakeLists.txt
flang/lib/Semantics/check-data.cpp
flang/lib/Semantics/check-data.h
flang/lib/Semantics/compute-offsets.cpp
flang/lib/Semantics/semantics.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/block-data01.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h
index 2007d9770f6e..69cf7ce5d730 100644
--- a/flang/include/flang/Evaluate/initial-image.h
+++ b/flang/include/flang/Evaluate/initial-image.h
@@ -87,6 +87,8 @@ class InitialImage {
void AddPointer(ConstantSubscript, const Expr<SomeType> &);
+ void Incorporate(ConstantSubscript, const InitialImage &);
+
// Conversions to constant initializers
std::optional<Expr<SomeType>> AsConstant(FoldingContext &,
const DynamicType &, const ConstantSubscripts &,
diff --git a/flang/include/flang/Parser/parsing.h b/flang/include/flang/Parser/parsing.h
index 9b84705d8151..9f8bff9e1d70 100644
--- a/flang/include/flang/Parser/parsing.h
+++ b/flang/include/flang/Parser/parsing.h
@@ -62,8 +62,6 @@ class Parsing {
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
index b6fdb35bdb08..0824d26eea74 100644
--- a/flang/include/flang/Semantics/semantics.h
+++ b/flang/include/flang/Semantics/semantics.h
@@ -170,6 +170,7 @@ class SemanticsContext {
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 @@ class SemanticsContext {
IndexVarKind kind;
};
std::map<SymbolRef, const IndexVarInfo> activeIndexVars_;
+ std::vector<std::string> tempNames_;
};
class Semantics {
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index 36cd1bb73a91..835d7a8ea3ea 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -53,7 +53,7 @@ class Bound {
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
index 6c6c74d49c01..5d768a89eb6b 100644
--- 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 <cstring>
namespace Fortran::evaluate {
@@ -53,6 +54,13 @@ void InitialImage::AddPointer(
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
index d7a7d107878d..b77242ae0876 100644
--- a/flang/lib/Parser/parsing.cpp
+++ b/flang/lib/Parser/parsing.cpp
@@ -123,24 +123,4 @@ void Parsing::Parse(llvm::raw_ostream &out) {
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
index 5d8406143772..d82926220b3e 100644
--- a/flang/lib/Semantics/CMakeLists.txt
+++ b/flang/lib/Semantics/CMakeLists.txt
@@ -26,6 +26,7 @@ add_flang_library(FortranSemantics
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.cpp b/flang/lib/Semantics/check-data.cpp
index 49e28ba3a091..fccda8ce55a9 100644
--- 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 <algorithm>
+#include <vector>
namespace Fortran::semantics {
@@ -193,8 +190,8 @@ void DataChecker::Leave(const parser::DataIDoObject &object) {
}
}
}
+ currentSetHasFatalErrors_ = true;
}
- currentSetHasFatalErrors_ = true;
}
void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
@@ -213,434 +210,15 @@ void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
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<std::list<parser::DataStmtValue>>(set.t).end()},
- at_{std::get<std::list<parser::DataStmtValue>>(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<parser::DataStmtValue>::const_iterator;
- void SetRepetitionCount();
- const parser::DataStmtConstant &GetConstant() const {
- return std::get<parser::DataStmtConstant>(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<std::pair<SomeExpr, bool>> 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<parser::Variable> &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<parser::DataImpliedDo::Bounds>(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<evaluate::ImpliedDoIndex>::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<std::list<parser::DataIDoObject>>(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<common::Indirection<parser::Designator>>
- &var) { return Scan(var.thing.value()); },
- [&](const common::Indirection<parser::DataImpliedDo> &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<std::pair<SomeExpr, bool>>
-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<std::string> chValue{evaluate::GetScalarConstantValue<
- evaluate::Type<TypeCategory::Character, 1>>(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<unsigned char>(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<std::size_t>(
- 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<std::size_t>(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<evaluate::BOZLiteralConstant>(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<std::list<parser::DataStmtObject>>(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<ConstantSubscript>(initialization.image.size()));
- }
- if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
- CHECK(IsProcedurePointer(symbol));
- const auto &procDesignator{initialization.image.AsConstantProcPointer()};
- CHECK(!procDesignator.GetComponent());
- auto &mutableProc{const_cast<ProcEntityDetails &>(*proc)};
- mutableProc.set_init(DEREF(procDesignator.GetSymbol()));
- } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (auto symbolType{evaluate::DynamicType::From(symbol)}) {
- auto &mutableObject{const_cast<ObjectEntityDetails &>(*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/check-data.h b/flang/lib/Semantics/check-data.h
index a6681831ea9d..eafecd902cb9 100644
--- 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 @@ struct DataStmtSet;
namespace Fortran::semantics {
-struct SymbolDataInitialization {
- using Range = common::Interval<ConstantSubscript>;
- explicit SymbolDataInitialization(std::size_t bytes) : image{bytes} {}
- evaluate::InitialImage image;
- std::list<Range> inits;
-};
-
-using DataInitializations = std::map<SymbolRef, SymbolDataInitialization>;
-
class DataChecker : public virtual BaseChecker {
public:
explicit DataChecker(SemanticsContext &context) : exprAnalyzer_{context} {}
@@ -55,7 +47,6 @@ class DataChecker : public virtual BaseChecker {
template <typename T> 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/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index 8b24f6a1f3ea..27acd18dae3a 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -51,6 +51,7 @@ class ComputeOffsetsHelper {
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 @@ class ComputeOffsetsHelper {
std::size_t alignment_{0};
// symbol -> symbol+offset that determines its location, from EQUIVALENCE
std::map<MutableSymbolRef, SymbolAndOffset> dependents_;
+ // base symbol -> SizeAndAlignment for each distinct EQUIVALENCE block
+ std::map<MutableSymbolRef, SizeAndAlignment> equivalenceBlock_;
};
void ComputeOffsetsHelper::Compute(Scope &scope) {
@@ -74,6 +77,8 @@ void ComputeOffsetsHelper::Compute(Scope &scope) {
Compute(child);
}
DoScope(scope);
+ dependents_.clear();
+ equivalenceBlock_.clear();
}
static bool InCommonBlock(const Symbol &symbol) {
@@ -85,33 +90,60 @@ void ComputeOffsetsHelper::DoScope(Scope &scope) {
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<ObjectEntityDetails>().set_commonBlock(*block);
}
}
- scope.set_size(offset_);
- scope.set_alignment(alignment_);
}
auto ComputeOffsetsHelper::Resolve(const SymbolAndOffset &dep)
@@ -131,11 +163,57 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
auto &details{commonBlock.get<CommonBlockDetails>()};
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<ObjectEntityDetails>().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.cpp b/flang/lib/Semantics/data-to-inits.cpp
new file mode 100644
index 000000000000..a7aaa7a10f6f
--- /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<std::list<parser::DataStmtValue>>(set.t).end()},
+ at_{std::get<std::list<parser::DataStmtValue>>(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<parser::DataStmtValue>::const_iterator;
+ void SetRepetitionCount();
+ const parser::DataStmtConstant &GetConstant() const {
+ return std::get<parser::DataStmtConstant>(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<std::pair<SomeExpr, bool>> 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<parser::Variable> &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<parser::DataImpliedDo::Bounds>(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<evaluate::ImpliedDoIndex>::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<std::list<parser::DataIDoObject>>(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<common::Indirection<parser::Designator>>
+ &var) { return Scan(var.thing.value()); },
+ [&](const common::Indirection<parser::DataImpliedDo> &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<std::pair<SomeExpr, bool>>
+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<std::string> chValue{evaluate::GetScalarConstantValue<
+ evaluate::Type<TypeCategory::Character, 1>>(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<unsigned char>(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<std::size_t>(
+ 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<std::size_t>(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<evaluate::BOZLiteralConstant>(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<std::list<parser::DataStmtObject>>(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<Scope &>(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<const Symbol *> 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<common::ConstantSubscript>(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<ObjectEntityDetails>()};
+ combinedSymbol.set_offset(minStart);
+ combinedSymbol.set_size(bytes);
+ details.set_type(typeSpec);
+ ArraySpec arraySpec;
+ arraySpec.emplace_back(ShapeSpec::MakeExplicit(Bound{
+ bytes / static_cast<common::ConstantSubscript>(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<std::size_t>(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<ConstantSubscript>(initialization.image.size()));
+ }
+ if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+ CHECK(IsProcedurePointer(symbol));
+ const auto &procDesignator{initialization.image.AsConstantProcPointer()};
+ CHECK(!procDesignator.GetComponent());
+ auto &mutableProc{const_cast<ProcEntityDetails &>(*proc)};
+ mutableProc.set_init(DEREF(procDesignator.GetSymbol()));
+ } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (auto symbolType{evaluate::DynamicType::From(symbol)}) {
+ auto &mutableObject{const_cast<ObjectEntityDetails &>(*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/data-to-inits.h b/flang/lib/Semantics/data-to-inits.h
new file mode 100644
index 000000000000..87926fc957c5
--- /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 <list>
+#include <map>
+
+namespace Fortran::parser {
+struct DataStmtSet;
+}
+namespace Fortran::evaluate {
+class ExpressionAnalyzer;
+}
+namespace Fortran::semantics {
+
+class Symbol;
+
+struct SymbolDataInitialization {
+ using Range = common::Interval<common::ConstantSubscript>;
+ explicit SymbolDataInitialization(std::size_t bytes) : image{bytes} {}
+ evaluate::InitialImage image;
+ std::list<Range> inits;
+};
+
+using DataInitializations = std::map<const Symbol *, SymbolDataInitialization>;
+
+// 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/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index e949c92ff6dd..d156fa319a0c 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -324,6 +324,18 @@ SymbolVector SemanticsContext::GetIndexVars(IndexVarKind kind) {
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
index 57b6c7544256..1942695a70c6 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -439,7 +439,7 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DerivedTypeSpec &x) {
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
index 853506cf3eb9..6424824f4606 100644
--- a/flang/test/Semantics/block-data01.f90
+++ b/flang/test/Semantics/block-data01.f90
@@ -14,12 +14,20 @@ block data foo
!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
index 000000000000..1550787b0d4c
--- /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
More information about the flang-commits
mailing list