diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -62,6 +62,7 @@ Constant *Folding(std::optional &); Expr CSHIFT(FunctionRef &&); + Expr EOSHIFT(FunctionRef &&); Expr RESHAPE(FunctionRef &&); private: @@ -619,6 +620,112 @@ return MakeInvalidIntrinsic(std::move(funcRef)); } +template Expr Folder::EOSHIFT(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 4); + const auto *array{UnwrapConstantValue(args[0])}; + const auto *shiftExpr{UnwrapExpr>(args[1])}; + auto dim{GetInt64ArgOr(args[3], 1)}; + if (!array || !shiftExpr || !dim) { + return Expr{std::move(funcRef)}; + } + // Apply type conversions to the shift= and boundary= arguments. + auto convertedShift{Fold(context_, + ConvertToType(Expr{*shiftExpr}))}; + const auto *shift{UnwrapConstantValue(convertedShift)}; + if (!shift) { + return Expr{std::move(funcRef)}; + } + const Constant *boundary{nullptr}; + std::optional> convertedBoundary; + if (const auto *boundaryExpr{UnwrapExpr>(args[2])}) { + convertedBoundary = Fold(context_, + ConvertToType(array->GetType(), Expr{*boundaryExpr})); + boundary = UnwrapExpr>(convertedBoundary); + if (!boundary) { + return Expr{std::move(funcRef)}; + } + } + // Arguments are constant + if (*dim < 1 || *dim > array->Rank()) { + context_.messages().Say( + "Invalid 'dim=' argument (%jd) in EOSHIFT"_err_en_US, + static_cast(*dim)); + } else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) { + // message already emitted from intrinsic look-up + } else { + int rank{array->Rank()}; + int zbDim{static_cast(*dim) - 1}; + bool ok{true}; + if (shift->Rank() > 0) { + int k{0}; + for (int j{0}; j < rank; ++j) { + if (j != zbDim) { + if (array->shape()[j] != shift->shape()[k]) { + context_.messages().Say( + "Invalid 'shift=' argument in EOSHIFT; extent on dimension %d is %jd but must be %jd"_err_en_US, + k + 1, static_cast(shift->shape()[k]), + static_cast(array->shape()[j])); + ok = false; + } + if (boundary && array->shape()[j] != boundary->shape()[k]) { + context_.messages().Say( + "Invalid 'boundary=' argument in EOSHIFT; extent on dimension %d is %jd but must be %jd"_err_en_US, + k + 1, static_cast(shift->shape()[k]), + static_cast(array->shape()[j])); + ok = false; + } + ++k; + } + } + } + if (ok) { + std::vector> resultElements; + ConstantSubscripts arrayAt{array->lbounds()}; + ConstantSubscript dimLB{arrayAt[zbDim]}; + ConstantSubscript dimExtent{array->shape()[zbDim]}; + ConstantSubscripts shiftAt{shift->lbounds()}; + ConstantSubscripts boundaryAt; + if (boundary) { + boundaryAt = boundary->lbounds(); + } + for (auto n{GetSize(array->shape())}; n > 0; n -= dimExtent) { + ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()}; + for (ConstantSubscript j{0}; j < dimExtent; ++j) { + ConstantSubscript zbAt{shiftCount + j}; + if (zbAt >= 0 && zbAt < dimExtent) { + arrayAt[zbDim] = dimLB + zbAt; + resultElements.push_back(array->At(arrayAt)); + } else if (boundary) { + resultElements.push_back(boundary->At(boundaryAt)); + } else if constexpr (T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Complex || + T::category == TypeCategory::Logical) { + resultElements.emplace_back(); + } else if constexpr (T::category == TypeCategory::Character) { + auto len{static_cast(array->LEN())}; + typename Scalar::value_type space{' '}; + resultElements.emplace_back(len, space); + } else { + DIE("no derived type boundary"); + } + } + arrayAt[zbDim] = dimLB + dimExtent - 1; + array->IncrementSubscripts(arrayAt); + shift->IncrementSubscripts(shiftAt); + if (boundary) { + boundary->IncrementSubscripts(boundaryAt); + } + } + return Expr{PackageConstant( + std::move(resultElements), *array, array->shape())}; + } + } + // Invalid, prevent re-folding + return MakeInvalidIntrinsic(std::move(funcRef)); +} + template Expr Folder::RESHAPE(FunctionRef &&funcRef) { auto args{funcRef.arguments()}; CHECK(args.size() == 4); @@ -754,6 +861,8 @@ const std::string name{intrinsic->name}; if (name == "cshift") { return Folder{context}.CSHIFT(std::move(funcRef)); + } else if (name == "eoshift") { + return Folder{context}.EOSHIFT(std::move(funcRef)); } else if (name == "reshape") { return Folder{context}.RESHAPE(std::move(funcRef)); } diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp --- a/flang/lib/Evaluate/fold-logical.cpp +++ b/flang/lib/Evaluate/fold-logical.cpp @@ -125,7 +125,7 @@ name == "__builtin_ieee_support_underflow_control") { return Expr{true}; } - // TODO: btest, dot_product, eoshift, is_iostat_end, + // TODO: btest, dot_product, is_iostat_end, // is_iostat_eor, lge, lgt, lle, llt, logical, matmul, out_of_range, // parity, transfer return Expr{std::move(funcRef)}; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -385,15 +385,17 @@ {"eoshift", {{"array", SameIntrinsic, Rank::array}, {"shift", AnyInt, Rank::dimRemovedOrScalar}, - {"boundary", SameIntrinsic, Rank::dimReduced, + {"boundary", SameIntrinsic, Rank::dimRemovedOrScalar, Optionality::optional}, OptionalDIM}, SameIntrinsic, Rank::conformable, IntrinsicClass::transformationalFunction}, {"eoshift", {{"array", SameDerivedType, Rank::array}, - {"shift", AnyInt, Rank::dimReduced}, - {"boundary", SameDerivedType, Rank::dimReduced}, OptionalDIM}, + {"shift", AnyInt, Rank::dimRemovedOrScalar}, + // BOUNDARY= is not optional for derived types + {"boundary", SameDerivedType, Rank::dimRemovedOrScalar}, + OptionalDIM}, SameDerivedType, Rank::conformable, IntrinsicClass::transformationalFunction}, {"epsilon", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, diff --git a/flang/test/Evaluate/folding23.f90 b/flang/test/Evaluate/folding23.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Evaluate/folding23.f90 @@ -0,0 +1,16 @@ +! RUN: %S/test_folding.sh %s %t %flang_fc1 +! REQUIRES: shell +! Tests folding of EOSHIFT (valid cases) +module m + integer, parameter :: arr(2,3) = reshape([1, 2, 3, 4, 5, 6], shape(arr)) + logical, parameter :: test_sanity = all([arr] == [1, 2, 3, 4, 5, 6]) + logical, parameter :: test_eoshift_0 = all(eoshift([1, 2, 3], 0) == [1, 2, 3]) + logical, parameter :: test_eoshift_1 = all(eoshift([1, 2, 3], 1) == [2, 3, 0]) + logical, parameter :: test_eoshift_2 = all(eoshift([1, 2, 3], -1) == [0, 1, 2]) + logical, parameter :: test_eoshift_3 = all(eoshift([1., 2., 3.], 1) == [2., 3., 0.]) + logical, parameter :: test_eoshift_4 = all(eoshift(['ab', 'cd', 'ef'], -1, 'x') == ['x ', 'ab', 'cd']) + logical, parameter :: test_eoshift_5 = all([eoshift(arr, 1, dim=1)] == [2, 0, 4, 0, 6, 0]) + logical, parameter :: test_eoshift_6 = all([eoshift(arr, 1, dim=2)] == [3, 5, 0, 4, 6, 0]) + logical, parameter :: test_eoshift_7 = all([eoshift(arr, [1, -1, 0])] == [2, 0, 0, 3, 5, 6]) + logical, parameter :: test_eoshift_8 = all([eoshift(arr, [1, -1], dim=2)] == [3, 5, 0, 0, 2, 4]) +end module