diff --git a/flang/include/flang/Evaluate/real.h b/flang/include/flang/Evaluate/real.h --- a/flang/include/flang/Evaluate/real.h +++ b/flang/include/flang/Evaluate/real.h @@ -155,6 +155,26 @@ static constexpr int MAXEXPONENT{maxExponent - exponentBias}; static constexpr int MINEXPONENT{2 - exponentBias}; + // SCALE(); also known as IEEE_SCALB and (in IEEE-754 '08) ScaleB. + template + ValueWithRealFlags SCALE( + const INT &by, Rounding rounding = defaultRounding) const { + auto expo{exponentBias + by.ToInt64()}; + if (IsZero()) { + expo = exponentBias; // ignore by, don't overflow + } else if (by > INT{maxExponent}) { + expo = maxExponent; + } else if (by < INT{-exponentBias}) { + expo = -1; + } + Real twoPow; + RealFlags flags{ + twoPow.Normalize(false, static_cast(expo), Fraction::MASKL(1))}; + ValueWithRealFlags result{Multiply(twoPow, rounding)}; + result.flags |= flags; + return result; + } + constexpr Real FlushSubnormalToZero() const { if (IsSubnormal()) { return Real{}; diff --git a/flang/lib/Evaluate/constant.cpp b/flang/lib/Evaluate/constant.cpp --- a/flang/lib/Evaluate/constant.cpp +++ b/flang/lib/Evaluate/constant.cpp @@ -342,5 +342,8 @@ return semantics::SymbolSourcePositionCompare{}(x, y); } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif INSTANTIATE_CONSTANT_TEMPLATES } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/expression.cpp b/flang/lib/Evaluate/expression.cpp --- a/flang/lib/Evaluate/expression.cpp +++ b/flang/lib/Evaluate/expression.cpp @@ -324,5 +324,8 @@ return std::visit([](const auto &kx) { return kx.LEN(); }, u); } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif INSTANTIATE_EXPRESSION_TEMPLATES } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/fold-character.cpp b/flang/lib/Evaluate/fold-character.cpp --- a/flang/lib/Evaluate/fold-character.cpp +++ b/flang/lib/Evaluate/fold-character.cpp @@ -140,6 +140,9 @@ return Expr{std::move(x)}; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif FOR_EACH_CHARACTER_KIND(template class ExpressionBase, ) template class ExpressionBase; } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/fold-complex.cpp b/flang/lib/Evaluate/fold-complex.cpp --- a/flang/lib/Evaluate/fold-complex.cpp +++ b/flang/lib/Evaluate/fold-complex.cpp @@ -78,6 +78,9 @@ return Expr{std::move(x)}; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif FOR_EACH_COMPLEX_KIND(template class ExpressionBase, ) template class ExpressionBase; } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -1020,6 +1020,9 @@ } } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif FOR_EACH_INTEGER_KIND(template class ExpressionBase, ) template class ExpressionBase; } // namespace Fortran::evaluate 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 @@ -254,6 +254,9 @@ return Expr{std::move(operation)}; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif FOR_EACH_LOGICAL_KIND(template class ExpressionBase, ) template class ExpressionBase; } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp --- a/flang/lib/Evaluate/fold-real.cpp +++ b/flang/lib/Evaluate/fold-real.cpp @@ -130,6 +130,31 @@ if (auto *expr{args[0].value().UnwrapExpr()}) { return ToReal(context, std::move(*expr)); } + } else if (name == "scale") { + if (const auto *byExpr{UnwrapExpr>(args[1])}) { + return std::visit( + [&](const auto &byVal) { + using TBY = ResultType; + return FoldElementalIntrinsic(context, + std::move(funcRef), + ScalarFunc( + [&](const Scalar &x, const Scalar &y) -> Scalar { + ValueWithRealFlags> result{x. +// MSVC chokes on the keyword "template" here in a call to a +// member function template. +#ifndef _MSC_VER + template +#endif + SCALE(y)}; + if (result.flags.test(RealFlag::Overflow)) { + context.messages().Say( + "SCALE intrinsic folding overflow"_en_US); + } + return result.value; + })); + }, + byExpr->u); + } } else if (name == "sign") { return FoldElementalIntrinsic( context, std::move(funcRef), &Scalar::SIGN); @@ -143,7 +168,7 @@ return Expr{Scalar::TINY()}; } // TODO: dim, dot_product, fraction, matmul, - // modulo, nearest, norm2, rrspacing, scale, + // modulo, nearest, norm2, rrspacing, // __builtin_next_after/down/up, // set_exponent, spacing, transfer, // bessel_jn (transformational) and bessel_yn (transformational) @@ -175,6 +200,9 @@ return Expr{std::move(x)}; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif FOR_EACH_REAL_KIND(template class ExpressionBase, ) template class ExpressionBase; } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -785,6 +785,9 @@ return o; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif INSTANTIATE_CONSTANT_TEMPLATES INSTANTIATE_EXPRESSION_TEMPLATES INSTANTIATE_VARIABLE_TEMPLATES diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/lib/Evaluate/variable.cpp @@ -685,6 +685,9 @@ dimension_ == that.dimension_; } +#ifdef _MSC_VER // disable bogus warning about missing definitions +#pragma warning(disable : 4661) +#endif INSTANTIATE_VARIABLE_TEMPLATES } // namespace Fortran::evaluate diff --git a/flang/test/Evaluate/errors01.f90 b/flang/test/Evaluate/errors01.f90 --- a/flang/test/Evaluate/errors01.f90 +++ b/flang/test/Evaluate/errors01.f90 @@ -100,4 +100,10 @@ !CHECK: error: DIM=4 argument to SPREAD must be between 1 and 3 integer, parameter :: bad3 = spread(matrix, 4, 1) end subroutine + subroutine warnings + real, parameter :: ok1 = scale(0.0, 99999) ! 0.0 + real, parameter :: ok2 = scale(1.0, -99999) ! 0.0 + !CHECK: SCALE intrinsic folding overflow + real, parameter :: bad1 = scale(1.0, 99999) + end subroutine end module diff --git a/flang/test/Evaluate/fold-scale.f90 b/flang/test/Evaluate/fold-scale.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Evaluate/fold-scale.f90 @@ -0,0 +1,11 @@ +! RUN: %python %S/test_folding.py %s %flang_fc1 +! Tests folding of SCALE() +module m + logical, parameter :: test_1 = scale(1.0, 1) == 2.0 + logical, parameter :: test_2 = scale(0.0, 1) == 0.0 + logical, parameter :: test_3 = sign(1.0, scale(-0.0, 1)) == -1.0 + logical, parameter :: test_4 = sign(1.0, scale(0.0, 0)) == 1.0 + logical, parameter :: test_5 = scale(1.0, -1) == 0.5 + logical, parameter :: test_6 = scale(2.0, -1) == 1.0 +end module +