[flang] Fold SET_EXPONENT() and FRACTION()

[klausler]

Summary

Fold the intrinsic function SET_EXPONENT() and its special case,
FRACTION().

flang/include/flang/Evaluate/real.h

public:
 
   static constexpr int DIGITS{binaryPrecision};
   static constexpr int PRECISION{Details::decimalPrecision};
   static constexpr int RANGE{Details::decimalRange};
   static constexpr int MAXEXPONENT{maxExponent - exponentBias};
   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 <typename INT>
   ValueWithRealFlags<Real> SCALE(const INT &by,
       Rounding rounding = TargetCharacteristics::defaultRounding) const {
     auto expo{exponentBias + by.ToInt64()};
     if (IsZero()) {
       expo = exponentBias; // ignore by, don't overflow

flang/lib/Evaluate/fold-real.cpp

 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
     FoldingContext &context,
     FunctionRef<Type<TypeCategory::Real, KIND>> &&funcRef) {
   using T = Type<TypeCategory::Real, KIND>;
   using ComplexT = Type<TypeCategory::Complex, KIND>;
+  using Int4 = Type<TypeCategory::Integer, 4>;
   ActualArguments &args{funcRef.arguments()};
   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
   CHECK(intrinsic);
   std::string name{intrinsic->name};
   if (name == "acos" || name == "acosh" || name == "asin" || name == "asinh" ||
       (name == "atan" && args.size() == 1) || name == "atanh" ||
       name == "bessel_j0" || name == "bessel_j1" || name == "bessel_y0" ||
       name == "bessel_y1" || name == "cos" || name == "cosh" || name == "erf" ||
if (name == "acos" || name == "acosh" || name == "asin" || name == "asinh" ||
     } else {
       context.messages().Say(
           "%s(real(kind=%d), real(kind%d)) cannot be folded on host"_warn_en_US,
           name, KIND, KIND);
     }
   } else if (name == "bessel_jn" || name == "bessel_yn") {
     if (args.size() == 2) { // elemental
       // runtime functions use int arg
-      using Int4 = Type<TypeCategory::Integer, 4>;
       if (auto callable{GetHostRuntimeWrapper<T, Int4, T>(name)}) {
         return FoldElementalIntrinsic<T, Int4, T>(
             context, std::move(funcRef), *callable);
       } else {
         context.messages().Say(
             "%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_warn_en_US,
             name, KIND);
       }
Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
   } else if (name == "dprod") {
     if (auto scalars{GetScalarConstantArguments<T, T>(context, args)}) {
       return Fold(context,
           Expr<T>{Multiply<T>{
               Expr<T>{std::get<0>(*scalars)}, Expr<T>{std::get<1>(*scalars)}}});
     }
   } else if (name == "epsilon") {
     return Expr<T>{Scalar<T>::EPSILON()};
+  } else if (name == "fraction") {
+    return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
+        ScalarFunc<T, T>(
+            [](const Scalar<T> &x) -> Scalar<T> { return x.FRACTION(); }));
   } else if (name == "huge") {
     return Expr<T>{Scalar<T>::HUGE()};
   } else if (name == "hypot") {
     CHECK(args.size() == 2);
     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
         ScalarFunc<T, T, T>(
             [](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {
               return x.HYPOT(y).value;
#endif
                         context.messages().Say(
                             "SCALE intrinsic folding overflow"_warn_en_US);
                       }
                       return result.value;
                     }));
           },
           byExpr->u);
     }
+  } else if (name == "set_exponent") {
+    return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
+        ScalarFunc<T, T, Int4>(
+            [&](const Scalar<T> &x, const Scalar<Int4> &i) -> Scalar<T> {
+              return x.SET_EXPONENT(i.ToInt64());
+            }));
   } else if (name == "sign") {
     return FoldElementalIntrinsic<T, T, T>(
         context, std::move(funcRef), &Scalar<T>::SIGN);
   } else if (name == "spacing") {
     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
         ScalarFunc<T, T>(
             [](const Scalar<T> &x) -> Scalar<T> { return x.SPACING(); }));
   } else if (name == "sqrt") {
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
                 "%s intrinsic folding overflow"_warn_en_US, iName);
           } else if (result.flags.test(RealFlag::InvalidArgument)) {
             context.messages().Say(
                 "%s intrinsic folding: bad argument"_warn_en_US, iName);
           }
           return result.value;
         }));
   }
-  // TODO: dot_product, fraction, matmul, norm2, set_exponent
+  // TODO: dot_product, matmul, norm2
   return Expr<T>{std::move(funcRef)};
 }
 
 #ifdef _MSC_VER // disable bogus warning about missing definitions
 #pragma warning(disable : 4661)
 #endif
 FOR_EACH_REAL_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeReal>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/real.cpp

template <typename W, int P> Real<W, P> Real<W, P>::SPACING() const {
   } else {
     Real result;
     result.Normalize(
         false, Exponent() - binaryPrecision + 1, Fraction::MASKL(1));
     return result;
   }
 }
 
+// 16.9.171
+template <typename W, int P>
+Real<W, P> Real<W, P>::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 <typename W, int P> Real<W, P> Real<W, P>::FRACTION() const {
+  return SET_EXPONENT(0);
+}
+
 template class Real<Integer<16>, 11>;
 template class Real<Integer<16>, 8>;
 template class Real<Integer<32>, 24>;
 template class Real<Integer<64>, 53>;
 template class Real<Integer<80>, 64>;
 template class Real<Integer<128>, 113>;
 } // namespace Fortran::evaluate::value

flang/test/Evaluate/folding07.f90

module m
   real(16), parameter :: tiny16 = tiny(0._16), ztiny16 = real(z'00010000000000000000000000000000', kind=16)
   logical, parameter :: test_tiny2 = tiny2 == ztiny2
   logical, parameter :: test_tiny3 = tiny3 == ztiny3
   logical, parameter :: test_tiny4 = tiny4 == ztiny4
   logical, parameter :: test_tiny8 = tiny8 == ztiny8
   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), &
     max3 = maxexponent(0._3), &
     max4 = maxexponent(0._4), &
     max8 = maxexponent(0._8), &
     max10 = maxexponent(0._10), &
     max16 = maxexponent(0._16)
integer, parameter :: &
     arange16 = range(0._16), zrange16 = range((0._16, 0._16))
   logical, parameter :: test_arange2 = arange2 == 4 .and. zrange2 == 4
   logical, parameter :: test_arange3 = arange3 == 37 .and. zrange3 == 37
   logical, parameter :: test_zrange4 = arange4 == 37 .and. zrange4 == 37
   logical, parameter :: test_zrange8 = arange8 == 307 .and. zrange8 == 307
   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