diff --git a/flang/documentation/Extensions.md b/flang/documentation/Extensions.md index 126947553f28d..a2420c727e82f 100644 --- a/flang/documentation/Extensions.md +++ b/flang/documentation/Extensions.md @@ -119,6 +119,8 @@ Extensions, deletions, and legacy features supported by default * An effectively empty source file (no program unit) is accepted and produces an empty relocatable output file. * A `RETURN` statement may appear in a main program. +* DATA statement initialization is allowed for procedure pointers outside + structure constructors. Extensions supported when enabled by options -------------------------------------------- diff --git a/flang/include/flang/Evaluate/fold-designator.h b/flang/include/flang/Evaluate/fold-designator.h index c6b6cfe70fe03..457e86d4fdad9 100644 --- a/flang/include/flang/Evaluate/fold-designator.h +++ b/flang/include/flang/Evaluate/fold-designator.h @@ -62,10 +62,8 @@ class DesignatorFolder { public: explicit DesignatorFolder(FoldingContext &c) : context_{c} {} - DesignatorFolder &Reset() { - elementNumber_ = 0; - return *this; - } + bool isEmpty() const { return isEmpty_; } + bool isOutOfRange() const { return isOutOfRange_; } template std::optional FoldDesignator(const Expr &expr) { @@ -75,52 +73,50 @@ class DesignatorFolder { } private: + std::optional FoldDesignator(const Symbol &, ConstantSubscript); std::optional FoldDesignator( - const Symbol &, ConstantSubscript) const; - std::optional FoldDesignator( - const SymbolRef &x, ConstantSubscript which) const { + const SymbolRef &x, ConstantSubscript which) { return FoldDesignator(*x, which); } std::optional FoldDesignator( - const ArrayRef &, ConstantSubscript) const; + const ArrayRef &, ConstantSubscript); std::optional FoldDesignator( - const Component &, ConstantSubscript) const; + const Component &, ConstantSubscript); std::optional FoldDesignator( - const ComplexPart &, ConstantSubscript) const; + const ComplexPart &, ConstantSubscript); std::optional FoldDesignator( - const Substring &, ConstantSubscript) const; + const Substring &, ConstantSubscript); std::optional FoldDesignator( - const DataRef &, ConstantSubscript) const; + const DataRef &, ConstantSubscript); std::optional FoldDesignator( - const NamedEntity &, ConstantSubscript) const; + const NamedEntity &, ConstantSubscript); std::optional FoldDesignator( - const CoarrayRef &, ConstantSubscript) const; + const CoarrayRef &, ConstantSubscript); std::optional FoldDesignator( - const ProcedureDesignator &, ConstantSubscript) const; + const ProcedureDesignator &, ConstantSubscript); template std::optional FoldDesignator( - const Expr &expr, ConstantSubscript which) const { + const Expr &expr, ConstantSubscript which) { return std::visit( [&](const auto &x) { return FoldDesignator(x, which); }, expr.u); } template - std::optional FoldDesignator( - const A &x, ConstantSubscript) const { - DIE("DesignatorFolder::FoldDesignator(): unexpected object in designator"); + std::optional FoldDesignator(const A &x, ConstantSubscript) { + return std::nullopt; } template std::optional FoldDesignator( - const Designator &designator, ConstantSubscript which) const { + const Designator &designator, ConstantSubscript which) { return std::visit( [&](const auto &x) { return FoldDesignator(x, which); }, designator.u); } template std::optional FoldDesignator( const Designator> &designator, - ConstantSubscript which) const { + ConstantSubscript which) { return std::visit( common::visitors{ [&](const Substring &ss) { @@ -128,15 +124,26 @@ class DesignatorFolder { if (auto result{FoldDesignator(*dataRef, which)}) { if (auto start{ToInt64(ss.lower())}) { std::optional end; + auto len{dataRef->LEN()}; if (ss.upper()) { end = ToInt64(*ss.upper()); - } else if (auto len{dataRef->LEN()}) { + } else if (len) { end = ToInt64(*len); } if (end) { + if (*start < 1) { + isOutOfRange_ = true; + } result->Augment(KIND * (*start - 1)); result->set_size( *end >= *start ? KIND * (*end - *start + 1) : 0); + if (len) { + if (auto lenVal{ToInt64(*len)}) { + if (*end > *lenVal) { + isOutOfRange_ = true; + } + } + } return result; } } @@ -151,6 +158,8 @@ class DesignatorFolder { FoldingContext &context_; ConstantSubscript elementNumber_{0}; // zero-based + bool isEmpty_{false}; + bool isOutOfRange_{false}; }; // Reconstructs a Designator<> from a symbol and an offset. diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h index 33c890b02d749..2007d9770f6eb 100644 --- a/flang/include/flang/Evaluate/initial-image.h +++ b/flang/include/flang/Evaluate/initial-image.h @@ -22,42 +22,65 @@ namespace Fortran::evaluate { class InitialImage { public: + enum Result { + Ok, + NotAConstant, + OutOfRange, + SizeMismatch, + }; + explicit InitialImage(std::size_t bytes) : data_(bytes) {} std::size_t size() const { return data_.size(); } - template bool Add(ConstantSubscript, std::size_t, const A &) { - return false; + template Result Add(ConstantSubscript, std::size_t, const A &) { + return NotAConstant; } template - bool Add(ConstantSubscript offset, std::size_t bytes, const Constant &x) { - CHECK(offset >= 0 && offset + bytes <= data_.size()); - auto elementBytes{x.GetType().MeasureSizeInBytes()}; - CHECK(elementBytes && bytes == x.values().size() * *elementBytes); - std::memcpy(&data_.at(offset), &x.values().at(0), bytes); - return true; + Result Add( + ConstantSubscript offset, std::size_t bytes, const Constant &x) { + if (offset < 0 || offset + bytes > data_.size()) { + return OutOfRange; + } else { + auto elementBytes{x.GetType().MeasureSizeInBytes()}; + if (!elementBytes || bytes != x.values().size() * *elementBytes) { + return SizeMismatch; + } else { + std::memcpy(&data_.at(offset), &x.values().at(0), bytes); + return Ok; + } + } } template - bool Add(ConstantSubscript offset, std::size_t bytes, + Result Add(ConstantSubscript offset, std::size_t bytes, const Constant> &x) { - CHECK(offset >= 0 && offset + bytes <= data_.size()); - auto elements{TotalElementCount(x.shape())}; - auto elementBytes{bytes > 0 ? bytes / elements : 0}; - CHECK(elements * elementBytes == bytes); - for (auto at{x.lbounds()}; elements-- > 0; x.IncrementSubscripts(at)) { - auto scalar{x.At(at)}; // this is a std string; size() in chars - // Subtle: an initializer for a substring may have been - // expanded to the length of the entire string. - CHECK(scalar.size() * KIND == elementBytes || - (elements == 0 && scalar.size() * KIND > elementBytes)); - std::memcpy(&data_[offset], scalar.data(), elementBytes); - offset += elementBytes; + if (offset < 0 || offset + bytes > data_.size()) { + return OutOfRange; + } else { + auto elements{TotalElementCount(x.shape())}; + auto elementBytes{bytes > 0 ? bytes / elements : 0}; + if (elements * elementBytes != bytes) { + return SizeMismatch; + } else { + for (auto at{x.lbounds()}; elements-- > 0; x.IncrementSubscripts(at)) { + auto scalar{x.At(at)}; // this is a std string; size() in chars + // Subtle: an initializer for a substring may have been + // expanded to the length of the entire string. + auto scalarBytes{scalar.size() * KIND}; + if (scalarBytes < elementBytes || + (scalarBytes > elementBytes && elements != 0)) { + return SizeMismatch; + } + std::memcpy(&data_[offset], scalar.data(), elementBytes); + offset += elementBytes; + } + return Ok; + } } - return true; } - bool Add(ConstantSubscript, std::size_t, const Constant &); + Result Add(ConstantSubscript, std::size_t, const Constant &); template - bool Add(ConstantSubscript offset, std::size_t bytes, const Expr &x) { + Result Add(ConstantSubscript offset, std::size_t bytes, const Expr &x) { return std::visit( [&](const auto &y) { return Add(offset, bytes, y); }, x.u); } diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index c561c9e609035..933638d039d35 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -1409,7 +1409,7 @@ struct DataStmtConstant { std::variant, Scalar, SignedIntLiteralConstant, SignedRealLiteralConstant, SignedComplexLiteralConstant, NullInit, InitialDataTarget, - Constant> + StructureConstructor> u; }; @@ -1425,7 +1425,7 @@ struct DataStmtRepeat { // R843 data-stmt-value -> [data-stmt-repeat *] data-stmt-constant struct DataStmtValue { TUPLE_CLASS_BOILERPLATE(DataStmtValue); - mutable std::size_t repetitions{1}; // replaced during semantics + mutable std::int64_t repetitions{1}; // replaced during semantics std::tuple, DataStmtConstant> t; }; diff --git a/flang/lib/Evaluate/fold-designator.cpp b/flang/lib/Evaluate/fold-designator.cpp index b33436296e954..5c56cd2acf5eb 100644 --- a/flang/lib/Evaluate/fold-designator.cpp +++ b/flang/lib/Evaluate/fold-designator.cpp @@ -14,15 +14,18 @@ namespace Fortran::evaluate { DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(OffsetSymbol) std::optional DesignatorFolder::FoldDesignator( - const Symbol &symbol, ConstantSubscript which) const { + const Symbol &symbol, ConstantSubscript which) { if (semantics::IsPointer(symbol) || semantics::IsAllocatable(symbol)) { // A pointer may appear as a DATA statement object if it is the // rightmost symbol in a designator and has no subscripts. // An allocatable may appear if its initializer is NULL(). - if (which == 0) { + if (which > 0) { + isEmpty_ = true; + } else { return OffsetSymbol{symbol, symbol.size()}; } - } else if (symbol.has()) { + } else if (symbol.has() && + !IsNamedConstant(symbol)) { if (auto type{DynamicType::From(symbol)}) { if (auto bytes{type->MeasureSizeInBytes()}) { if (auto extents{GetConstantExtents(context_, symbol)}) { @@ -38,7 +41,9 @@ std::optional DesignatorFolder::FoldDesignator( which = quotient; stride *= extent; } - if (which == 0) { + if (which > 0) { + isEmpty_ = true; + } else { return std::move(result); } } @@ -49,7 +54,7 @@ std::optional DesignatorFolder::FoldDesignator( } std::optional DesignatorFolder::FoldDesignator( - const ArrayRef &x, ConstantSubscript which) const { + const ArrayRef &x, ConstantSubscript which) { const Symbol &array{x.base().GetLastSymbol()}; if (auto type{DynamicType::From(array)}) { if (auto bytes{type->MeasureSizeInBytes()}) { @@ -88,11 +93,12 @@ std::optional DesignatorFolder::FoldDesignator( auto remainder{which - value->size() * quotient}; ConstantSubscript at{ value->values().at(remainder).ToInt64()}; - if (at >= lower && at <= upper) { - result->Augment((at - lower) * stride); - which = quotient; - return true; + if (at < lower || at > upper) { + isOutOfRange_ = true; } + result->Augment((at - lower) * stride); + which = quotient; + return true; } } return false; @@ -124,7 +130,9 @@ std::optional DesignatorFolder::FoldDesignator( ++dim; stride *= extent; } - if (which == 0) { + if (which > 0) { + isEmpty_ = true; + } else { return result; } } @@ -135,7 +143,7 @@ std::optional DesignatorFolder::FoldDesignator( } std::optional DesignatorFolder::FoldDesignator( - const Component &component, ConstantSubscript which) const { + const Component &component, ConstantSubscript which) { const Symbol &comp{component.GetLastSymbol()}; const DataRef &base{component.base()}; std::optional result, baseResult; @@ -156,7 +164,7 @@ std::optional DesignatorFolder::FoldDesignator( } std::optional DesignatorFolder::FoldDesignator( - const ComplexPart &z, ConstantSubscript which) const { + const ComplexPart &z, ConstantSubscript which) { if (auto result{FoldDesignator(z.complex(), which)}) { result->set_size(result->size() >> 1); if (z.part() == ComplexPart::Part::IM) { @@ -169,28 +177,30 @@ std::optional DesignatorFolder::FoldDesignator( } std::optional DesignatorFolder::FoldDesignator( - const DataRef &dataRef, ConstantSubscript which) const { + const DataRef &dataRef, ConstantSubscript which) { return std::visit( [&](const auto &x) { return FoldDesignator(x, which); }, dataRef.u); } std::optional DesignatorFolder::FoldDesignator( - const NamedEntity &entity, ConstantSubscript which) const { + const NamedEntity &entity, ConstantSubscript which) { return entity.IsSymbol() ? FoldDesignator(entity.GetLastSymbol(), which) : FoldDesignator(entity.GetComponent(), which); } std::optional DesignatorFolder::FoldDesignator( - const CoarrayRef &, ConstantSubscript) const { + const CoarrayRef &, ConstantSubscript) { return std::nullopt; } std::optional DesignatorFolder::FoldDesignator( - const ProcedureDesignator &proc, ConstantSubscript which) const { + const ProcedureDesignator &proc, ConstantSubscript which) { if (const Symbol * symbol{proc.GetSymbol()}) { if (const Component * component{proc.GetComponent()}) { return FoldDesignator(*component, which); - } else if (which == 0) { + } else if (which > 0) { + isEmpty_ = true; + } else { return FoldDesignator(*symbol, 0); } } @@ -217,7 +227,7 @@ static std::optional OffsetToArrayRef(FoldingContext &context, auto element{offset / *elementBytes}; std::vector subscripts; auto at{element}; - for (int dim{0}; dim < rank; ++dim) { + for (int dim{0}; dim + 1 < rank; ++dim) { auto extent{(*extents)[dim]}; if (extent <= 0) { return std::nullopt; @@ -227,11 +237,10 @@ static std::optional OffsetToArrayRef(FoldingContext &context, subscripts.emplace_back(ExtentExpr{(*lower)[dim] + remainder}); at = quotient; } - if (at == 0) { - offset -= element * *elementBytes; - return ArrayRef{std::move(entity), std::move(subscripts)}; - } - return std::nullopt; + // This final subscript might be out of range for use in error reporting. + subscripts.emplace_back(ExtentExpr{(*lower)[rank - 1] + at}); + offset -= element * *elementBytes; + return ArrayRef{std::move(entity), std::move(subscripts)}; } // Maps an offset back to a component, when unambiguous. @@ -255,6 +264,7 @@ static const Symbol *OffsetToUniqueComponent( } // Converts an offset into subscripts &/or component references. Recursive. +// Any remaining offset is left in place in the "offset" reference argument. static std::optional OffsetToDataRef(FoldingContext &context, NamedEntity &&entity, ConstantSubscript &offset, std::size_t size) { const Symbol &symbol{entity.GetLastSymbol()}; diff --git a/flang/lib/Evaluate/initial-image.cpp b/flang/lib/Evaluate/initial-image.cpp index a32d359cbb01c..6c6c74d49c015 100644 --- a/flang/lib/Evaluate/initial-image.cpp +++ b/flang/lib/Evaluate/initial-image.cpp @@ -12,30 +12,40 @@ namespace Fortran::evaluate { -bool InitialImage::Add(ConstantSubscript offset, std::size_t bytes, - const Constant &x) { - CHECK(offset >= 0 && offset + bytes <= data_.size()); - auto elements{TotalElementCount(x.shape())}; - auto elementBytes{bytes > 0 ? bytes / elements : 0}; - CHECK(elements * elementBytes == bytes); - auto at{x.lbounds()}; - for (auto elements{TotalElementCount(x.shape())}; elements-- > 0; - x.IncrementSubscripts(at)) { - auto scalar{x.At(at)}; - // TODO: length type parameter values? - for (const auto &[symbolRef, indExpr] : scalar) { - const Symbol &component{*symbolRef}; - CHECK(component.offset() + component.size() <= elementBytes); - if (IsPointer(component)) { - AddPointer(offset + component.offset(), indExpr.value()); - } else if (!Add(offset + component.offset(), component.size(), - indExpr.value())) { - return false; +auto InitialImage::Add(ConstantSubscript offset, std::size_t bytes, + const Constant &x) -> Result { + if (offset < 0 || offset + bytes > data_.size()) { + return OutOfRange; + } else { + auto elements{TotalElementCount(x.shape())}; + auto elementBytes{bytes > 0 ? bytes / elements : 0}; + if (elements * elementBytes != bytes) { + return SizeMismatch; + } else { + auto at{x.lbounds()}; + for (auto elements{TotalElementCount(x.shape())}; elements-- > 0; + x.IncrementSubscripts(at)) { + auto scalar{x.At(at)}; + // TODO: length type parameter values? + for (const auto &[symbolRef, indExpr] : scalar) { + const Symbol &component{*symbolRef}; + if (component.offset() + component.size() > elementBytes) { + return SizeMismatch; + } else if (IsPointer(component)) { + AddPointer(offset + component.offset(), indExpr.value()); + } else { + Result added{Add(offset + component.offset(), component.size(), + indExpr.value())}; + if (added != Ok) { + return Ok; + } + } + } + offset += elementBytes; } } - offset += elementBytes; + return Ok; } - return true; } void InitialImage::AddPointer( diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp index 6368b985d1aa1..3192781d4bcc9 100644 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -833,7 +833,7 @@ TYPE_PARSER(sourced(first( construct(scalar(Parser{})), construct(nullInit), construct(scalar(constantSubobject)) / !"("_tok, - construct(constant(Parser{})), + construct(Parser{}), construct(signedRealLiteralConstant), construct(signedIntLiteralConstant), extension( diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp index 7c5557714f460..7e86790a529e3 100644 --- a/flang/lib/Semantics/check-data.cpp +++ b/flang/lib/Semantics/check-data.cpp @@ -6,9 +6,22 @@ // //===----------------------------------------------------------------------===// +// 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(). + #include "check-data.h" +#include "pointer-assignment.h" +#include "flang/Evaluate/fold-designator.h" #include "flang/Evaluate/traverse.h" -#include "flang/Semantics/expression.h" +#include "flang/Parser/parse-tree.h" +#include "flang/Parser/tools.h" +#include "flang/Semantics/tools.h" namespace Fortran::semantics { @@ -18,7 +31,9 @@ void DataChecker::Enter(const parser::DataImpliedDo &x) { auto name{std::get(x.t).name.thing.thing}; int kind{evaluate::ResultType::kind}; if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) { - kind = dynamicType->kind(); + if (dynamicType->category() == TypeCategory::Integer) { + kind = dynamicType->kind(); + } } exprAnalyzer_.AddImpliedDo(name.source, kind); } @@ -28,6 +43,9 @@ void DataChecker::Leave(const parser::DataImpliedDo &x) { exprAnalyzer_.RemoveImpliedDo(name.source); } +// DataVarChecker applies static checks once to each variable that appears +// in a data-stmt-set. These checks are independent of the values that +// correspond to the variables. class DataVarChecker : public evaluate::AllTraverse { public: using Base = evaluate::AllTraverse; @@ -37,6 +55,35 @@ class DataVarChecker : public evaluate::AllTraverse { bool HasComponentWithoutSubscripts() const { return hasComponent_ && !hasSubscript_; } + bool operator()(const Symbol &symbol) { // C876 + // 8.6.7p(2) - precludes non-pointers of derived types with + // default component values + const Scope &scope{context_.FindScope(source_)}; + bool isFirstSymbol{isFirstSymbol_}; + isFirstSymbol_ = false; + if (const char *whyNot{IsAutomatic(symbol) ? "Automatic variable" + : IsDummy(symbol) ? "Dummy argument" + : IsFunctionResult(symbol) ? "Function result" + : IsAllocatable(symbol) ? "Allocatable" + : IsInitialized(symbol, true) ? "Default-initialized" + : IsInBlankCommon(symbol) ? "Blank COMMON object" + : IsProcedure(symbol) && !IsPointer(symbol) ? "Procedure" + // remaining checks don't apply to components + : !isFirstSymbol ? nullptr + : IsHostAssociated(symbol, scope) ? "Host-associated object" + : IsUseAssociated(symbol, scope) ? "USE-associated object" + : nullptr}) { + context_.Say(source_, + "%s '%s' must not be initialized in a DATA statement"_err_en_US, + whyNot, symbol.name()); + return false; + } else if (IsProcedurePointer(symbol)) { + context_.Say(source_, + "Procedure pointer '%s' in a DATA statement is not standard"_en_US, + symbol.name()); + } + return true; + } bool operator()(const evaluate::Component &component) { hasComponent_ = true; const Symbol &lastSymbol{component.GetLastSymbol()}; @@ -56,12 +103,6 @@ class DataVarChecker : public evaluate::AllTraverse { return false; } } - if (!isFirstSymbolChecked_) { - isFirstSymbolChecked_ = true; - if (!CheckFirstSymbol(component.GetFirstSymbol())) { - return false; - } - } return (*this)(component.base()) && (*this)(lastSymbol); } bool operator()(const evaluate::ArrayRef &arrayRef) { @@ -74,18 +115,10 @@ class DataVarChecker : public evaluate::AllTraverse { (*this)(substring.upper()); } bool operator()(const evaluate::CoarrayRef &) { // C874 - hasSubscript_ = true; context_.Say( source_, "Data object must not be a coindexed variable"_err_en_US); return false; } - bool operator()(const evaluate::Symbol &symbol) { - if (!isFirstSymbolChecked_) { - return CheckFirstSymbol(symbol) && CheckAnySymbol(symbol); - } else { - return CheckAnySymbol(symbol); - } - } bool operator()(const evaluate::Subscript &subs) { DataVarChecker subscriptChecker{context_, source_}; subscriptChecker.RestrictPointer(); @@ -130,64 +163,15 @@ class DataVarChecker : public evaluate::AllTraverse { return true; } } - bool CheckFirstSymbol(const Symbol &symbol); - bool CheckAnySymbol(const Symbol &symbol); SemanticsContext &context_; parser::CharBlock source_; bool hasComponent_{false}; bool hasSubscript_{false}; bool isPointerAllowed_{true}; - bool isFirstSymbolChecked_{false}; + bool isFirstSymbol_{true}; }; -bool DataVarChecker::CheckFirstSymbol(const Symbol &symbol) { // C876 - const Scope &scope{context_.FindScope(source_)}; - if (IsDummy(symbol)) { - context_.Say(source_, - "Data object part '%s' must not be a dummy argument"_err_en_US, - symbol.name().ToString()); - } else if (IsFunction(symbol)) { - context_.Say(source_, - "Data object part '%s' must not be a function name"_err_en_US, - symbol.name().ToString()); - } else if (symbol.IsFuncResult()) { - context_.Say(source_, - "Data object part '%s' must not be a function result"_err_en_US, - symbol.name().ToString()); - } else if (IsHostAssociated(symbol, scope)) { - context_.Say(source_, - "Data object part '%s' must not be accessed by host association"_err_en_US, - symbol.name().ToString()); - } else if (IsUseAssociated(symbol, scope)) { - context_.Say(source_, - "Data object part '%s' must not be accessed by use association"_err_en_US, - symbol.name().ToString()); - } else if (IsInBlankCommon(symbol)) { - context_.Say(source_, - "Data object part '%s' must not be in blank COMMON"_err_en_US, - symbol.name().ToString()); - } else { - return true; - } - return false; -} - -bool DataVarChecker::CheckAnySymbol(const Symbol &symbol) { // C876 - if (IsAutomaticObject(symbol)) { - context_.Say(source_, - "Data object part '%s' must not be an automatic object"_err_en_US, - symbol.name().ToString()); - } else if (IsAllocatable(symbol)) { - context_.Say(source_, - "Data object part '%s' must not be an allocatable object"_err_en_US, - symbol.name().ToString()); - } else { - return true; - } - return false; -} - void DataChecker::Leave(const parser::DataIDoObject &object) { if (const auto *designator{ std::get_if>>( @@ -195,26 +179,436 @@ void DataChecker::Leave(const parser::DataIDoObject &object) { if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) { auto source{designator->thing.value().source}; if (evaluate::IsConstantExpr(*expr)) { // C878,C879 - exprAnalyzer_.Say( + exprAnalyzer_.context().Say( source, "Data implied do object must be a variable"_err_en_US); } else { DataVarChecker checker{exprAnalyzer_.context(), source}; - if (checker(*expr) && checker.HasComponentWithoutSubscripts()) { // C880 - exprAnalyzer_.Say(source, - "Data implied do structure component must be subscripted"_err_en_US); + if (checker(*expr)) { + if (checker.HasComponentWithoutSubscripts()) { // C880 + exprAnalyzer_.context().Say(source, + "Data implied do structure component must be subscripted"_err_en_US); + } else { + return; + } } } } } + currentSetHasFatalErrors_ = true; } void DataChecker::Leave(const parser::DataStmtObject &dataObject) { - if (const auto *var{ - std::get_if>(&dataObject.u)}) { - if (auto expr{exprAnalyzer_.Analyze(*var)}) { - DataVarChecker{exprAnalyzer_.context(), - parser::FindSourceLocation(dataObject)}(expr); + std::visit(common::visitors{ + [](const parser::DataImpliedDo &) { // has own Enter()/Leave() + }, + [&](const auto &var) { + auto expr{exprAnalyzer_.Analyze(var)}; + if (!expr || + !DataVarChecker{exprAnalyzer_.context(), + parser::FindSourceLocation(dataObject)}(*expr)) { + currentSetHasFatalErrors_ = true; + } + }, + }, + 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); + + 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(); +} + +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{ + evaluate::ConvertToType(*designatorType, SomeExpr{*expr})}) { + // 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()); + } + auto folded{evaluate::Fold(context, std::move(*converted))}; + 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); + } + } + 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); + } +} + } // namespace Fortran::semantics diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h index fa65737ecefba..a6681831ea9dc 100644 --- a/flang/lib/Semantics/check-data.h +++ b/flang/lib/Semantics/check-data.h @@ -9,26 +9,57 @@ #ifndef FORTRAN_SEMANTICS_CHECK_DATA_H_ #define FORTRAN_SEMANTICS_CHECK_DATA_H_ -#include "flang/Parser/parse-tree.h" -#include "flang/Parser/tools.h" +#include "flang/Common/interval.h" +#include "flang/Evaluate/fold-designator.h" +#include "flang/Evaluate/initial-image.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/semantics.h" -#include "flang/Semantics/tools.h" +#include +#include +#include + +namespace Fortran::parser { +struct DataStmtRepeat; +struct DataStmtObject; +struct DataIDoObject; +class DataStmtImpliedDo; +struct DataStmtSet; +} // namespace Fortran::parser 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} {} void Leave(const parser::DataStmtObject &); + void Leave(const parser::DataIDoObject &); void Enter(const parser::DataImpliedDo &); void Leave(const parser::DataImpliedDo &); - void Leave(const parser::DataIDoObject &); + void Leave(const parser::DataStmtSet &); + + // After all DATA statements have been processed, converts their + // initializations into per-symbol static initializers. + void CompileDataInitializationsIntoInitializers(); private: - evaluate::ExpressionAnalyzer exprAnalyzer_; + ConstantSubscript GetRepetitionCount(const parser::DataStmtRepeat &); 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_; + bool currentSetHasFatalErrors_{false}; }; } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_CHECK_DATA_H_ diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index afd70d0651080..60e705f0ee88f 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -707,7 +707,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) { if (MaybeExpr value{Analyze(n.v)}) { Expr folded{Fold(std::move(*value))}; if (IsConstantExpr(folded)) { - return {folded}; + return folded; } Say(n.v.source, "must be a constant"_err_en_US); // C718 } @@ -725,7 +725,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) { MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) { if (const auto &repeat{ std::get>(x.t)}) { - x.repetitions = 0; + x.repetitions = -1; if (MaybeExpr expr{Analyze(repeat->u)}) { Expr folded{Fold(std::move(*expr))}; if (auto value{ToInt64(folded)}) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 9efc7991b4aeb..2b257fce9fd6d 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -5059,9 +5059,8 @@ bool ConstructVisitor::Pre(const parser::DataStmtValue &x) { if (const Symbol * symbol{FindSymbol(*name)}) { if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) { if (ultimate->has()) { - mutableData.u = parser::Constant{ - elem->ConvertToStructureConstructor( - DerivedTypeSpec{name->source, *ultimate})}; + mutableData.u = elem->ConvertToStructureConstructor( + DerivedTypeSpec{name->source, *ultimate}); } } } diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp index b8327213682b6..681e1dc5ca274 100644 --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -168,7 +168,11 @@ static bool PerformStatementSemantics( ComputeOffsets(context); CheckDeclarations(context); StatementSemanticsPass1{context}.Walk(program); - StatementSemanticsPass2{context}.Walk(program); + StatementSemanticsPass2 pass2{context}; + pass2.Walk(program); + if (!context.AnyFatalError()) { + pass2.CompileDataInitializationsIntoInitializers(); + } return !context.AnyFatalError(); } diff --git a/flang/test/Semantics/data01.f90 b/flang/test/Semantics/data01.f90 index 8fa36991801ea..aea40f0c78ba4 100644 --- a/flang/test/Semantics/data01.f90 +++ b/flang/test/Semantics/data01.f90 @@ -1,6 +1,6 @@ ! RUN: %S/test_errors.sh %s %t %f18 !Test for checking data constraints, C882-C887 -subroutine CheckRepeat +module m1 type person integer :: age character(len=25) :: name @@ -9,55 +9,58 @@ subroutine CheckRepeat integer ::notConstDigits(5) real, parameter::numbers(5) = ( /-11.11,-22.22,-33.33,44.44,55.55/ ) integer, parameter :: repeat = -1 - integer :: myAge = 2 - type(person) myName + integer :: myAge = 2 + type(person) associated +end + +subroutine CheckRepeat + use m1 + type(person) myName(6) !C882 !ERROR: Missing initialization for parameter 'uninitialized' integer, parameter :: uninitialized !C882 !ERROR: Repeat count (-1) for data value must not be negative - DATA myName%age / repeat * 35 / + DATA myName(1)%age / repeat * 35 / !C882 !ERROR: Repeat count (-11) for data value must not be negative - DATA myName%age / digits(1) * 35 / + DATA myName(2)%age / digits(1) * 35 / !C882 !ERROR: Must be a constant value - DATA myName%age / repet * 35 / + DATA myName(3)%age / repet * 35 / !C885 !ERROR: Must have INTEGER type, but is REAL(4) - DATA myName%age / numbers(1) * 35 / + DATA myName(4)%age / numbers(1) * 35 / !C886 !ERROR: Must be a constant value - DATA myName%age / notConstDigits(1) * 35 / + DATA myName(5)%age / notConstDigits(1) * 35 / !C887 !ERROR: Must be a constant value - DATA myName%age / digits(myAge) * 35 / + DATA myName(6)%age / digits(myAge) * 35 / end subroutine CheckValue - type person - integer :: age - character(len=25) :: name - end type - integer :: myAge = 2 - type(person) myName + use m1 + !ERROR: USE-associated object 'associated' must not be initialized in a DATA statement + data associated / person(1, 'Abcd Ijkl') / + type(person) myName(3) !OK: constant structure constructor - data myname / person(1, 'Abcd Ijkl') / + data myname(1) / person(1, 'Abcd Ijkl') / !C883 !ERROR: 'persn' is not an array - data myname / persn(2, 'Abcd Efgh') / + data myname(2) / persn(2, 'Abcd Efgh') / !C884 - !ERROR: Must be a constant value - data myname / person(myAge, 'Abcd Ijkl') / + !ERROR: DATA statement value 'person(age=myage,name="Abcd Ijkl ")' for 'myname(3_8)%age' is not a constant + data myname(3) / person(myAge, 'Abcd Ijkl') / integer, parameter :: a(5) =(/11, 22, 33, 44, 55/) integer :: b(5) =(/11, 22, 33, 44, 55/) integer :: i - integer :: x + integer :: x, y, z !OK: constant array element data x / a(1) / !C886, C887 !ERROR: Must be a constant value - data x / a(i) / + data y / a(i) / !ERROR: Must be a constant value - data x / b(1) / + data z / b(1) / end diff --git a/flang/test/Semantics/data03.f90 b/flang/test/Semantics/data03.f90 index fdab401d9b9be..f5b65035f73d0 100644 --- a/flang/test/Semantics/data03.f90 +++ b/flang/test/Semantics/data03.f90 @@ -70,10 +70,10 @@ subroutine CheckObject DATA(newNumsArray(i) % one, i = 1, 5) / 5 * 1 / !C880 !OK: Correct use - DATA(largeArray(j) % nums % one, j = 1, 10) / 10 * 1 / + DATA(largeArray(j) % nums % one, j = 1, 5) / 5 * 1 / !C880 !OK: Correct use - DATA(largeNumber % numsArray(j) % one, j = 1, 10) / 10 * 1 / + DATA(largeNumber % numsArray(j) % one, j = 1, 5) / 5 * 1 / !C881 !ERROR: Data object must have constant subscripts DATA(b(x), i = 1, 5) / 5 * 1 / diff --git a/flang/test/Semantics/data04.f90 b/flang/test/Semantics/data04.f90 index a34f59337f71f..f1f772e48051d 100644 --- a/flang/test/Semantics/data04.f90 +++ b/flang/test/Semantics/data04.f90 @@ -6,7 +6,7 @@ module m subroutine h integer a,b !C876 - !ERROR: Data object part 'first' must not be accessed by host association + !ERROR: Host-associated object 'first' must not be initialized in a DATA statement DATA first /1/ end subroutine @@ -23,25 +23,25 @@ function f(i) character(len=i), pointer:: charPtr character(len=i), allocatable:: charAlloc !C876 - !ERROR: Data object part 'i' must not be a dummy argument + !ERROR: Dummy argument 'i' must not be initialized in a DATA statement DATA i /1/ !C876 - !ERROR: Data object part 'f' must not be a function result + !ERROR: Function result 'f' must not be initialized in a DATA statement DATA f /1/ !C876 - !ERROR: Data object part 'g' must not be a function name + !ERROR: Procedure 'g' must not be initialized in a DATA statement DATA g /1/ !C876 - !ERROR: Data object part 'a' must not be an allocatable object + !ERROR: Allocatable 'a' must not be initialized in a DATA statement DATA a /1/ !C876 - !ERROR: Data object part 'b' must not be an automatic object + !ERROR: Automatic variable 'b' must not be initialized in a DATA statement DATA b(0) /1/ !C876 !Ok: As charPtr is a pointer, it is not an automatic object DATA charPtr / NULL() / !C876 - !ERROR: Data object part 'charalloc' must not be an allocatable object + !ERROR: Allocatable 'charalloc' must not be initialized in a DATA statement DATA charAlloc / 'abc' / f = i *1024 end @@ -67,11 +67,11 @@ subroutine CheckObject(i) type(large) :: largeArray(5) character :: name(i) !C877 - !OK: Correct use + !ERROR: Default-initialized 'largenumber' must not be initialized in a DATA statement DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() / !C877 !ERROR: Data object must not contain pointer 'headofthelist' as a non-rightmost part - DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * NULL() / + DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * 1 / !C877 !ERROR: Rightmost data object pointer 'ptoarray' must not be subscripted DATA(largeNumber % numsArray(j) % ptoarray(1), j = 1, 10) / 10 * 1 / @@ -79,19 +79,19 @@ subroutine CheckObject(i) !ERROR: Rightmost data object pointer 'ptochar' must not be subscripted DATA largeNumber % numsArray(0) % ptochar(1:2) / 'ab' / !C876 - !ERROR: Data object part 'elt' must not be an allocatable object + !ERROR: Default-initialized 'largenumber' must not be initialized in a DATA statement DATA(largeNumber % elt(j) , j = 1, 10) / 10 * 1/ !C876 - !ERROR: Data object part 'allocval' must not be an allocatable object + !ERROR: Default-initialized 'largearray' must not be initialized in a DATA statement DATA(largeArray(j) % allocVal , j = 1, 10) / 10 * 1/ !C876 - !ERROR: Data object part 'allocatablelarge' must not be an allocatable object + !ERROR: Allocatable 'allocatablelarge' must not be initialized in a DATA statement DATA allocatableLarge % val / 1 / !C876 - !ERROR: Data object part 'largenumberarray' must not be an automatic object + !ERROR: Automatic variable 'largenumberarray' must not be initialized in a DATA statement DATA(largeNumberArray(j) % val, j = 1, 10) / 10 * NULL() / !C876 - !ERROR: Data object part 'name' must not be an automatic object + !ERROR: Automatic variable 'name' must not be initialized in a DATA statement DATA name( : 2) / 'Ancd' / end end @@ -116,10 +116,10 @@ subroutine checkDerivedType(m2_number) type(newType) m2_number type(newType) m2_number3 !C876 - !ERROR: Data object part 'm2_number' must not be a dummy argument + !ERROR: Dummy argument 'm2_number' must not be initialized in a DATA statement DATA m2_number%number /1/ !C876 - !ERROR: Data object part 'm2_number1' must not be accessed by host association + !ERROR: Host-associated object 'm2_number1' must not be initialized in a DATA statement DATA m2_number1%number /1/ !C876 !OK: m2_number3 is not associated through use association @@ -139,18 +139,18 @@ program new COMMON b,a,c,num type(newType) m2_number2 !C876 - !ERROR: Data object part 'b' must not be in blank COMMON + !ERROR: Blank COMMON object 'b' must not be initialized in a DATA statement DATA b /1/ !C876 - !ERROR: Data object part 'm2_i' must not be accessed by use association + !ERROR: USE-associated object 'm2_i' must not be initialized in a DATA statement DATA m2_i /1/ !C876 - !ERROR: Data object part 'm2_number1' must not be accessed by use association + !ERROR: USE-associated object 'm2_number1' must not be initialized in a DATA statement DATA m2_number1%number /1/ !C876 !OK: m2_number2 is not associated through use association DATA m2_number2%number /1/ !C876 - !ERROR: Data object part 'num' must not be in blank COMMON + !ERROR: Blank COMMON object 'num' must not be initialized in a DATA statement DATA num%number /1/ end program diff --git a/flang/test/Semantics/data05.f90 b/flang/test/Semantics/data05.f90 new file mode 100644 index 0000000000000..a138b067942e5 --- /dev/null +++ b/flang/test/Semantics/data05.f90 @@ -0,0 +1,92 @@ +!RUN: %f18 -fdebug-dump-symbols -fparse-only %s | FileCheck %s +module m + interface + integer function ifunc(n) + integer, intent(in) :: n + end function + real function rfunc(x) + real, intent(in) :: x + end function + end interface + external extrfunc + real extrfunc + type :: t1(kind,len) + integer(kind=1), kind :: kind = 4 + integer(kind=2), len :: len = 1 + integer(kind=kind) :: j + real(kind=kind) :: x(2,2) + complex(kind=kind) :: z + logical(kind=kind) :: t + character(kind=5-kind) :: c(2) + real(kind=kind), pointer :: xp(:,:) + procedure(ifunc), pointer, nopass :: ifptr + procedure(rfunc), pointer, nopass :: rp + procedure(real), pointer, nopass :: xrp + end type + contains + subroutine s1 + procedure(ifunc), pointer :: ifptr ! CHECK: ifptr, EXTERNAL, POINTER (Function, InDataStmt) size=24 offset=0: ProcEntity ifunc => ifunc + data ifptr/ifunc/ + end subroutine + subroutine s2 + integer(kind=1) :: j1 ! CHECK: j1 (InDataStmt) size=1 offset=0: ObjectEntity type: INTEGER(1) init:66_1 + data j1/66/ + end subroutine + subroutine s3 + integer :: jd ! CHECK: jd (InDataStmt) size=4 offset=0: ObjectEntity type: INTEGER(4) init:666_4 + data jd/666/ + end subroutine + subroutine s4 + logical :: lv(2) ! CHECK: lv (InDataStmt) size=8 offset=0: ObjectEntity type: LOGICAL(4) shape: 1_8:2_8 init:[LOGICAL(4)::.false._4,.true._4] + data lv(1)/.false./ + data lv(2)/.true./ + end subroutine + subroutine s5 + real :: rm(2,2) ! CHECK: rm (InDataStmt) size=16 offset=0: ObjectEntity type: REAL(4) shape: 1_8:2_8,1_8:2_8 init:reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]) + data rm/1,2,3,4/ + end subroutine + subroutine s6 + character(len=8) :: ssd ! CHECK: ssd (InDataStmt) size=8 offset=0: ObjectEntity type: CHARACTER(8_4,1) init:"abcdefgh" + data ssd(1:4)/'abcd'/,ssd(5:8)/'efgh'/ + end subroutine + subroutine s7 + complex(kind=16) :: zv(-1:1) ! CHECK: zv (InDataStmt) size=96 offset=0: ObjectEntity type: COMPLEX(16) shape: -1_8:1_8 init:[COMPLEX(16)::(1._16,2._16),(3._16,4._16),(5._16,6._16)] + data (zv(j), j=1,0,-1)/(5,6),(3,4)/ + data (zv(j)%im, zv(j)%re, j=-1,-1,-9)/2,1/ + end subroutine + real function rfunc2(x) + real, intent(in) :: x + rfunc2 = x + 1. + end function + subroutine s8 + procedure(rfunc), pointer :: rfptr ! CHECK: rfptr, EXTERNAL, POINTER (Function, InDataStmt) size=24 offset=0: ProcEntity rfunc => rfunc2 + data rfptr/rfunc2/ + end subroutine + subroutine s10 + real, target, save :: arr(3,4) ! CHECK: arr, SAVE, TARGET size=48 offset=0: ObjectEntity type: REAL(4) shape: 1_8:3_8,1_8:4_8 + real, pointer :: xpp(:,:) ! CHECK: xpp, POINTER (InDataStmt) size=72 offset=48: ObjectEntity type: REAL(4) shape: :,: init:arr + data xpp/arr/ + end subroutine + integer function ifunc2(n) + integer, intent(in) :: n + ifunc2 = n + 1 + end function + subroutine s11 + real, target, save :: arr(3,4) ! CHECK: arr, SAVE, TARGET size=48 offset=0: ObjectEntity type: REAL(4) shape: 1_8:3_8,1_8:4_8 + type(t1) :: d1 = t1(1,reshape([1,2,3,4],[2,2]),(6.,7.),.false.,'ab',arr,ifunc2,rfunc,extrfunc) ! CHECK: d1 size=184 offset=48: ObjectEntity type: TYPE(t1(kind=4_1,len=1_2)) init:t1(kind=4_1,len=1_2)(j=1_4,x=reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]),z=(6._4,7._4),t=.false._4,c=[CHARACTER(KIND=1,LEN=1)::"a","a"],xp=arr,ifptr=ifunc2,rp=rfunc,xrp=extrfunc) + type(t1(4,len=1)) :: d2 = t1(4)(xrp=extrfunc,rp=rfunc,ifptr=ifunc2,xp=arr,c='a& + &b',t=.false.,z=(6.,7.),x=reshape([1,2,3,4],[2,2]),j=1) ! CHECK: d2 size=184 offset=232: ObjectEntity type: TYPE(t1(kind=4_1,len=1_2)) init:t1(kind=4_1,len=1_2)(j=1_4,x=reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]),z=(6._4,7._4),t=.false._4,c=[CHARACTER(KIND=1,LEN=1)::"a","a"],xp=arr,ifptr=ifunc2,rp=rfunc,xrp=extrfunc) + type(t1(2+2)) :: d3 ! CHECK: d3 (InDataStmt) size=184 offset=416: ObjectEntity type: TYPE(t1(kind=4_1,len=1_2)) init:t1(kind=4_1,len=1_2)(j=1_4,x=reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]),z=(6._4,7._4),t=.false._4,c=[CHARACTER(KIND=1,LEN=1)::"a","a"],xp=arr,ifptr=ifunc2,rp=rfunc,xrp=extrfunc) + data d3/t1(1,reshape([1,2,3,4],[2,2]),(6.,7.),.false.,'ab',arr,ifunc2,rfunc,extrfunc)/ + type(t1) :: d4 ! CHECK: d4 (InDataStmt) size=184 offset=600: ObjectEntity type: TYPE(t1(kind=4_1,len=1_2)) init:t1(kind=4_1,len=1_2)(j=1_4,x=reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]),z=(6._4,7._4),t=.false._4,c=[CHARACTER(KIND=1,LEN=1)::"a","a"],xp=arr,ifptr=ifunc2,rp=rfunc,xrp=extrfunc) + data d4/t1(4)(xrp=extrfunc,rp=rfunc,ifptr=ifunc2,xp=arr,c='ab',t=.false.,z=(6& + &.,7.),x=reshape([1,2,3,4],[2,2]),j=1)/ + type(t1) :: d5 ! CHECK: d5 (InDataStmt) size=184 offset=784: ObjectEntity type: TYPE(t1(kind=4_1,len=1_2)) init:t1(kind=4_1,len=1_2)(j=1_4,x=reshape([REAL(4)::1._4,2._4,3._4,4._4],shape=[2,2]),z=(6._4,7._4),t=.false._4,c=[CHARACTER(KIND=1,LEN=1)::"a","b"],xp=arr,ifptr=ifunc2,rp=rfunc,xrp=extrfunc) + data d5%j/1/,d5%x/1,2,3,4/,d5%z%re/6./,d5%z%im/7./,d5%t/.false./,d5%c(1:1)/'a'/,d5%c(2:& + &2)/'b'/,d5%xp/arr/,d5%ifptr/ifunc2/,d5%rp/rfunc/,d5%xrp/extrfunc/ + end subroutine + subroutine s12 + procedure(rfunc), pointer :: pp ! CHECK: pp, EXTERNAL, POINTER (Function, InDataStmt) size=24 offset=0: ProcEntity rfunc => rfunc2 + data pp/rfunc2/ + end subroutine +end module diff --git a/flang/test/Semantics/data06.f90 b/flang/test/Semantics/data06.f90 new file mode 100644 index 0000000000000..c21b99e8e484a --- /dev/null +++ b/flang/test/Semantics/data06.f90 @@ -0,0 +1,50 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! DATA statement errors +subroutine s1 + type :: t1 + integer :: j = 666 + end type t1 + type(t1) :: t1x + !ERROR: Default-initialized 't1x' must not be initialized in a DATA statement + data t1x%j / 777 / + integer :: ja = 888 + !ERROR: Default-initialized 'ja' must not be initialized in a DATA statement + data ja / 999 / + integer :: a1(10) + !ERROR: DATA statement set has more values than objects + data a1(1:9:2) / 6 * 1 / + integer :: a2(10) + !ERROR: DATA statement set has no value for 'a2(2_8)' + data (a2(k),k=10,1,-2) / 4 * 1 / + integer :: a3(2) + !ERROR: DATA statement implied DO loop has a step value of zero + data (a3(j),j=1,2,0)/2*333/ + integer :: a4(3) + !ERROR: DATA statement designator 'a4(5_8)' is out of range + data (a4(j),j=1,5,2) /3*222/ + interface + real function rfunc(x) + real, intent(in) :: x + end function + end interface + real, pointer :: rp + !ERROR: Procedure 'rfunc' may not be used to initialize 'rp', which is not a procedure pointer + data rp/rfunc/ + procedure(rfunc), pointer :: rpp + real, target :: rt + !ERROR: Data object 'rt' may not be used to initialize 'rpp', which is a procedure pointer + data rpp/rt/ + !ERROR: Initializer for 'rt' must not be a pointer + data rt/null()/ + !ERROR: Initializer for 'rt' must not be a procedure + data rt/rfunc/ + integer :: jx, jy + !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx' + data jx/'abc'/ + !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx' + data jx/t1()/ + !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx' + data jx/.false./ + !ERROR: must be a constant + data jx/jy/ +end subroutine diff --git a/flang/test/Semantics/data07.f90 b/flang/test/Semantics/data07.f90 new file mode 100644 index 0000000000000..6f47c261f89a7 --- /dev/null +++ b/flang/test/Semantics/data07.f90 @@ -0,0 +1,12 @@ +! RUN: %S/test_errors.sh %s %t %f18 +module m + contains + subroutine s1 + !ERROR: DATA statement initializations affect 'jb(5_8)' more than once + integer :: ja(10), jb(10) + data (ja(k),k=1,9,2) / 5*1 / ! ok + data (ja(k),k=10,2,-2) / 5*2 / ! ok + data (jb(k),k=1,9,2) / 5*1 / ! ok + data (jb(k),k=2,10,3) / 3*2 / ! conflict at 5 + end subroutine +end module