From e8f96899e17b11292940d8826338e2e0a64a22b9 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Fri, 30 Oct 2020 12:57:28 -0700 Subject: [PATCH] [flang] Allow array constructor implied DO loop indices as constant expressions When the bounds of an implied DO loop in an array constructor are constant, the index variable of that loop is considered a constant expression and can be used as such in the items in the value list of the implied DO loop. Since the KIND type parameter values of items in the value list can depend on the various values taken by such an index, it is not possible to represent those values with a single typed expression. So implement such loops by taking multiple passes over the parse tree of the implied DO loop instead. Differential revision: https://reviews.llvm.org/D90494 --- flang/include/flang/Parser/message.h | 2 +- flang/include/flang/Semantics/expression.h | 6 +- flang/lib/Semantics/expression.cpp | 246 ++++++++++++++++++--------- flang/test/Evaluate/folding13.f90 | 11 ++ flang/test/Semantics/array-constr-values.f90 | 3 + 5 files changed, 181 insertions(+), 87 deletions(-) create mode 100644 flang/test/Evaluate/folding13.f90 diff --git a/flang/include/flang/Parser/message.h b/flang/include/flang/Parser/message.h index cd1df0a..cbb42df 100644 --- a/flang/include/flang/Parser/message.h +++ b/flang/include/flang/Parser/message.h @@ -293,7 +293,7 @@ public: common::Restorer SetMessages(Messages &buffer) { return common::ScopedSet(messages_, &buffer); } - // Discard messages; destination restored when the returned value is deleted. + // Discard future messages until the returned value is deleted. common::Restorer DiscardMessages() { return common::ScopedSet(messages_, nullptr); } diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 75cf4fe..4862e98 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -146,6 +146,10 @@ public: return common::ScopedSet(isWholeAssumedSizeArrayOk_, true); } + common::Restorer DoNotUseSavedTypedExprs() { + return common::ScopedSet(useSavedTypedExprs_, false); + } + Expr AnalyzeKindSelector(common::TypeCategory category, const std::optional &); @@ -378,8 +382,8 @@ private: semantics::SemanticsContext &context_; FoldingContext &foldingContext_{context_.foldingContext()}; std::map impliedDos_; // values are INTEGER kinds - bool fatalErrors_{false}; bool isWholeAssumedSizeArrayOk_{false}; + bool useSavedTypedExprs_{true}; friend class ArgumentAnalyzer; }; diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 73534c3..8ffa547 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1184,15 +1184,24 @@ public: } private: + using ImpliedDoIntType = ResultType; + void Push(MaybeExpr &&); + void Add(const parser::AcValue::Triplet &); + void Add(const parser::Expr &); + void Add(const parser::AcImpliedDo &); + void UnrollConstantImpliedDo(const parser::AcImpliedDo &, + parser::CharBlock name, std::int64_t lower, std::int64_t upper, + std::int64_t stride); template std::optional>> GetSpecificIntExpr( const A &x) { if (MaybeExpr y{exprAnalyzer_.Analyze(x)}) { Expr *intExpr{UnwrapExpr>(*y)}; - return ConvertToType>( - std::move(DEREF(intExpr))); + return Fold(exprAnalyzer_.GetFoldingContext(), + ConvertToType>( + std::move(DEREF(intExpr)))); } return std::nullopt; } @@ -1204,7 +1213,7 @@ private: bool explicitType_{type_.has_value()}; std::optional constantLength_; ArrayConstructorValues values_; - bool messageDisplayedOnce{false}; + std::uint64_t messageDisplayedSet_{0}; }; void ArrayConstructorContext::Push(MaybeExpr &&x) { @@ -1238,9 +1247,12 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) { if (constantLength_) { if (exprAnalyzer_.context().warnOnNonstandardUsage() && *thisLen != *constantLength_) { - exprAnalyzer_.Say( - "Character literal in array constructor without explicit " - "type has different length than earlier element"_en_US); + if (!(messageDisplayedSet_ & 1)) { + exprAnalyzer_.Say( + "Character literal in array constructor without explicit " + "type has different length than earlier elements"_en_US); + messageDisplayedSet_ |= 1; + } } if (*thisLen > *constantLength_) { // Language extension: use the longest literal to determine the @@ -1255,111 +1267,176 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) { } } } else { - if (!messageDisplayedOnce) { + if (!(messageDisplayedSet_ & 2)) { exprAnalyzer_.Say( "Values in array constructor must have the same declared type " "when no explicit type appears"_err_en_US); // C7110 - messageDisplayedOnce = true; + messageDisplayedSet_ |= 2; } } } else { if (auto cast{ConvertToType(*type_, std::move(*x))}) { values_.Push(std::move(*cast)); - } else { + } else if (!(messageDisplayedSet_ & 4)) { exprAnalyzer_.Say( "Value in array constructor of type '%s' could not " "be converted to the type of the array '%s'"_err_en_US, x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112 + messageDisplayedSet_ |= 4; } } } } void ArrayConstructorContext::Add(const parser::AcValue &x) { - using IntType = ResultType; std::visit( common::visitors{ - [&](const parser::AcValue::Triplet &triplet) { - // Transform l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_' - std::optional> lower{ - GetSpecificIntExpr(std::get<0>(triplet.t))}; - std::optional> upper{ - GetSpecificIntExpr(std::get<1>(triplet.t))}; - std::optional> stride{ - GetSpecificIntExpr(std::get<2>(triplet.t))}; - if (lower && upper) { - if (!stride) { - stride = Expr{1}; - } - if (!type_) { - type_ = DynamicTypeWithLength{IntType::GetType()}; - } - auto v{std::move(values_)}; - parser::CharBlock anonymous; - Push(Expr{ - Expr{Expr{ImpliedDoIndex{anonymous}}}}); - std::swap(v, values_); - values_.Push(ImpliedDo{anonymous, std::move(*lower), - std::move(*upper), std::move(*stride), std::move(v)}); - } - }, + [&](const parser::AcValue::Triplet &triplet) { Add(triplet); }, [&](const common::Indirection &expr) { - auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation( - expr.value().source)}; - if (MaybeExpr v{exprAnalyzer_.Analyze(expr.value())}) { - if (auto exprType{v->GetType()}) { - if (exprType->IsUnlimitedPolymorphic()) { - exprAnalyzer_.Say( - "Cannot have an unlimited polymorphic value in an " - "array constructor"_err_en_US); // C7113 - } - } - Push(std::move(*v)); - } + Add(expr.value()); }, [&](const common::Indirection &impliedDo) { - const auto &control{ - std::get(impliedDo.value().t)}; - const auto &bounds{ - std::get(control.t)}; - exprAnalyzer_.Analyze(bounds.name); - parser::CharBlock name{bounds.name.thing.thing.source}; - const Symbol *symbol{bounds.name.thing.thing.symbol}; - int kind{IntType::kind}; - if (const auto dynamicType{DynamicType::From(symbol)}) { - kind = dynamicType->kind(); - } - if (exprAnalyzer_.AddImpliedDo(name, kind)) { - std::optional> lower{ - GetSpecificIntExpr(bounds.lower)}; - std::optional> upper{ - GetSpecificIntExpr(bounds.upper)}; - if (lower && upper) { - std::optional> stride{ - GetSpecificIntExpr(bounds.step)}; - auto v{std::move(values_)}; - for (const auto &value : - std::get>(impliedDo.value().t)) { - Add(value); - } - if (!stride) { - stride = Expr{1}; - } - std::swap(v, values_); - values_.Push(ImpliedDo{name, std::move(*lower), - std::move(*upper), std::move(*stride), std::move(v)}); - } - exprAnalyzer_.RemoveImpliedDo(name); - } else { - exprAnalyzer_.SayAt(name, - "Implied DO index is active in surrounding implied DO loop " - "and may not have the same name"_err_en_US); // C7115 - } + Add(impliedDo.value()); }, }, x.u); } +// Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_' +void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) { + std::optional> lower{ + GetSpecificIntExpr(std::get<0>(triplet.t))}; + std::optional> upper{ + GetSpecificIntExpr(std::get<1>(triplet.t))}; + std::optional> stride{ + GetSpecificIntExpr(std::get<2>(triplet.t))}; + if (lower && upper) { + if (!stride) { + stride = Expr{1}; + } + if (!type_) { + type_ = DynamicTypeWithLength{ImpliedDoIntType::GetType()}; + } + auto v{std::move(values_)}; + parser::CharBlock anonymous; + Push(Expr{ + Expr{Expr{ImpliedDoIndex{anonymous}}}}); + std::swap(v, values_); + values_.Push(ImpliedDo{anonymous, std::move(*lower), + std::move(*upper), std::move(*stride), std::move(v)}); + } +} + +void ArrayConstructorContext::Add(const parser::Expr &expr) { + auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)}; + if (MaybeExpr v{exprAnalyzer_.Analyze(expr)}) { + if (auto exprType{v->GetType()}) { + if (!(messageDisplayedSet_ & 8) && exprType->IsUnlimitedPolymorphic()) { + exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an " + "array constructor"_err_en_US); // C7113 + messageDisplayedSet_ |= 8; + } + } + Push(std::move(*v)); + } +} + +void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) { + const auto &control{std::get(impliedDo.t)}; + const auto &bounds{std::get(control.t)}; + exprAnalyzer_.Analyze(bounds.name); + parser::CharBlock name{bounds.name.thing.thing.source}; + const Symbol *symbol{bounds.name.thing.thing.symbol}; + int kind{ImpliedDoIntType::kind}; + if (const auto dynamicType{DynamicType::From(symbol)}) { + kind = dynamicType->kind(); + } + if (!exprAnalyzer_.AddImpliedDo(name, kind)) { + if (!(messageDisplayedSet_ & 0x20)) { + exprAnalyzer_.SayAt(name, + "Implied DO index is active in surrounding implied DO loop " + "and may not have the same name"_err_en_US); // C7115 + messageDisplayedSet_ |= 0x20; + } + return; + } + std::optional> lower{ + GetSpecificIntExpr(bounds.lower)}; + std::optional> upper{ + GetSpecificIntExpr(bounds.upper)}; + if (lower && upper) { + std::optional> stride{ + GetSpecificIntExpr(bounds.step)}; + if (!stride) { + stride = Expr{1}; + } + // Check for constant bounds; the loop may require complete unrolling + // of the parse tree if all bounds are constant in order to allow the + // implied DO loop index to qualify as a constant expression. + auto cLower{ToInt64(lower)}; + auto cUpper{ToInt64(upper)}; + auto cStride{ToInt64(stride)}; + if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) { + exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source, + "The stride of an implied DO loop must not be zero"_err_en_US); + messageDisplayedSet_ |= 0x10; + } + bool isConstant{cLower && cUpper && cStride && *cStride != 0}; + bool isNonemptyConstant{isConstant && + ((*cStride > 0 && *cLower <= *cUpper) || + (*cStride < 0 && *cLower >= *cUpper))}; + bool unrollConstantLoop{false}; + parser::Messages buffer; + auto saveMessagesDisplayed{messageDisplayedSet_}; + { + auto messageRestorer{ + exprAnalyzer_.GetContextualMessages().SetMessages(buffer)}; + auto v{std::move(values_)}; + for (const auto &value : + std::get>(impliedDo.t)) { + Add(value); + } + std::swap(v, values_); + if (isNonemptyConstant && buffer.AnyFatalError()) { + unrollConstantLoop = true; + } else { + values_.Push(ImpliedDo{name, std::move(*lower), + std::move(*upper), std::move(*stride), std::move(v)}); + } + } + if (unrollConstantLoop) { + messageDisplayedSet_ = saveMessagesDisplayed; + UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride); + } else if (auto *messages{ + exprAnalyzer_.GetContextualMessages().messages()}) { + messages->Annex(std::move(buffer)); + } + } + exprAnalyzer_.RemoveImpliedDo(name); +} + +// Fortran considers an implied DO index of an array constructor to be +// a constant expression if the bounds of the implied DO loop are constant. +// Usually this doesn't matter, but if we emitted spurious messages as a +// result of not using constant values for the index while analyzing the +// items, we need to do it again the "hard" way with multiple iterations over +// the parse tree. +void ArrayConstructorContext::UnrollConstantImpliedDo( + const parser::AcImpliedDo &impliedDo, parser::CharBlock name, + std::int64_t lower, std::int64_t upper, std::int64_t stride) { + auto &foldingContext{exprAnalyzer_.GetFoldingContext()}; + auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()}; + for (auto &at{foldingContext.StartImpliedDo(name, lower)}; + (stride > 0 && at <= upper) || (stride < 0 && at >= upper); + at += stride) { + for (const auto &value : + std::get>(impliedDo.t)) { + Add(value); + } + } + foldingContext.EndImpliedDo(name); +} + MaybeExpr ArrayConstructorContext::ToExpr() { return common::SearchTypes(std::move(*this)); } @@ -2525,7 +2602,7 @@ static void FixMisparsedFunctionReference( // representation of the analyzed expression. template MaybeExpr ExpressionAnalyzer::ExprOrVariable(const PARSED &x) { - if (x.typedExpr) { + if (useSavedTypedExprs_ && x.typedExpr) { return x.typedExpr->v; } if constexpr (std::is_same_v || @@ -2546,7 +2623,6 @@ MaybeExpr ExpressionAnalyzer::ExprOrVariable(const PARSED &x) { Say("Internal error: Expression analysis failed on: %s"_err_en_US, dump.str()); } - fatalErrors_ = true; return std::nullopt; } diff --git a/flang/test/Evaluate/folding13.f90 b/flang/test/Evaluate/folding13.f90 new file mode 100644 index 0000000..753b7be --- /dev/null +++ b/flang/test/Evaluate/folding13.f90 @@ -0,0 +1,11 @@ +! RUN: %S/test_folding.sh %s %t %f18 +! Test folding of array constructors with constant implied DO bounds; +! their indices are constant expressions and can be used as such. +module m1 + integer, parameter :: kinds(*) = [1, 2, 4, 8] + integer(kind=8), parameter :: clipping(*) = [integer(kind=8) :: & + (int(z'100010101', kind=kinds(j)), j=1,4)] + integer(kind=8), parameter :: expected(*) = [ & + int(z'01',8), int(z'0101',8), int(z'00010101',8), int(z'100010101',8)] + logical, parameter :: test_clipping = all(clipping == expected) +end module diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90 index 30739f8..2d815a3 100644 --- a/flang/test/Semantics/array-constr-values.f90 +++ b/flang/test/Semantics/array-constr-values.f90 @@ -57,4 +57,7 @@ subroutine checkC7115() !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name !ERROR: 'i' is already declared in this scoping unit real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)] + + !ERROR: The stride of an implied DO loop must not be zero + integer, parameter :: bad2(*) = [(j, j=1,1,0)] end subroutine checkC7115 -- 2.7.4