Index: flang/include/flang/Evaluate/real.h =================================================================== --- flang/include/flang/Evaluate/real.h +++ flang/include/flang/Evaluate/real.h @@ -170,6 +170,8 @@ static constexpr int MINEXPONENT{2 - exponentBias}; Real RRSPACING() const; Real SPACING() const; + Real SET_EXPONENT(int) const; + Real FRACTION() const; // SCALE(); also known as IEEE_SCALB and (in IEEE-754 '08) ScaleB. template Index: flang/lib/Evaluate/fold-real.cpp =================================================================== --- flang/lib/Evaluate/fold-real.cpp +++ flang/lib/Evaluate/fold-real.cpp @@ -49,6 +49,7 @@ FunctionRef> &&funcRef) { using T = Type; using ComplexT = Type; + using Int4 = Type; ActualArguments &args{funcRef.arguments()}; auto *intrinsic{std::get_if(&funcRef.proc().u)}; CHECK(intrinsic); @@ -86,7 +87,6 @@ } else if (name == "bessel_jn" || name == "bessel_yn") { if (args.size() == 2) { // elemental // runtime functions use int arg - using Int4 = Type; if (auto callable{GetHostRuntimeWrapper(name)}) { return FoldElementalIntrinsic( context, std::move(funcRef), *callable); @@ -144,6 +144,10 @@ } } else if (name == "epsilon") { return Expr{Scalar::EPSILON()}; + } else if (name == "fraction") { + return FoldElementalIntrinsic(context, std::move(funcRef), + ScalarFunc( + [](const Scalar &x) -> Scalar { return x.FRACTION(); })); } else if (name == "huge") { return Expr{Scalar::HUGE()}; } else if (name == "hypot") { @@ -250,6 +254,12 @@ }, byExpr->u); } + } else if (name == "set_exponent") { + return FoldElementalIntrinsic(context, std::move(funcRef), + ScalarFunc( + [&](const Scalar &x, const Scalar &i) -> Scalar { + return x.SET_EXPONENT(i.ToInt64()); + })); } else if (name == "sign") { return FoldElementalIntrinsic( context, std::move(funcRef), &Scalar::SIGN); @@ -315,7 +325,7 @@ return result.value; })); } - // TODO: dot_product, fraction, matmul, norm2, set_exponent + // TODO: dot_product, matmul, norm2 return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/real.cpp =================================================================== --- flang/lib/Evaluate/real.cpp +++ flang/lib/Evaluate/real.cpp @@ -755,6 +755,27 @@ } } +// 16.9.171 +template +Real Real::SET_EXPONENT(int expo) const { + if (IsNotANumber()) { + return *this; + } else if (IsInfinite()) { + return NotANumber(); + } else if (IsZero()) { + return *this; + } else { + Real result; + result.Normalize(IsNegative(), expo + exponentBias - 1, GetFraction()); + return result; + } +} + +// 16.9.171 +template Real Real::FRACTION() const { + return SET_EXPONENT(0); +} + template class Real, 11>; template class Real, 8>; template class Real, 24>; Index: flang/test/Evaluate/folding07.f90 =================================================================== --- flang/test/Evaluate/folding07.f90 +++ flang/test/Evaluate/folding07.f90 @@ -197,13 +197,25 @@ logical, parameter :: test_tiny10 = tiny10 == ztiny10 logical, parameter :: test_tiny16 = tiny16 == ztiny16 + real, parameter :: nan = real(z'7fc12345') + integer, parameter :: nanInt = int(z'7fc12345') + real, parameter :: inf = real(z'7f800000') logical, parameter :: test_exponent_0 = exponent(0.0) == 0 + logical, parameter :: test_fraction_0 = fraction(0.) == 0. logical, parameter :: test_exponent_r8 = exponent(0.125) == -2 + logical, parameter :: test_fraction_r8 = fraction(0.125) == 0.5 logical, parameter :: test_exponent_r4 = exponent(0.25) == -1 + logical, parameter :: test_fraction_mr4 = fraction(-0.25) == -0.5 logical, parameter :: test_exponent_r2 = exponent(0.5) == 0 + logical, parameter :: test_fraction_r2 = fraction(0.5) == 0.5 logical, parameter :: test_exponent_1 = exponent(1.0) == 1 + logical, parameter :: test_fraction_1 = fraction(1.) == 0.5 logical, parameter :: test_exponent_4 = exponent(4.1) == 3 + logical, parameter :: test_fraction_m4 = fraction(-4.5) == -0.5625 logical, parameter :: test_exponent_12 = exponent(12.9) == 4 + real, parameter :: fraction_inf = fraction(inf) + logical, parameter :: test_fraction_inf = fraction_inf /= fraction_inf ! must be NaN + logical, parameter :: test_fraction_nan = transfer(fraction(nan),0) == nanInt integer, parameter :: & max2 = maxexponent(0._2), & @@ -259,4 +271,14 @@ logical, parameter :: test_zrange10 = arange10 == 4931 .and. zrange10 == 4931 logical, parameter :: test_zrange16 = arange16 == 4931 .and. zrange16 == 4931 + logical, parameter :: test_set_exponent_z = set_exponent(0., 999) == 0. + logical, parameter :: test_set_exponent_nan = transfer(set_exponent(nan, 0), 0) == nanInt + real, parameter :: set_expo_inf = set_exponent(inf, 0) + integer, parameter :: set_expo_inf_int = transfer(set_expo_inf, 0) + logical, parameter :: test_set_exponent_inf = shiftr(set_expo_inf_int, 23) == 255 .and. & + shiftl(set_expo_inf_int, 9) /= 0 ! NaN + logical, parameter :: test_set_exponent_0 = set_exponent(1., 0) == 0.5 + logical, parameter :: test_set_exponent_1 = set_exponent(1., 1) == 1. + logical, parameter :: test_set_exponent_2 = set_exponent(1., 2) == 2. + end module