[flang] Fold SIGN()

Original-commit: flang-compiler/f18@521a02a
Reviewed-on: flang-compiler/f18#623
Tree-same-pre-rewrite: false

flang/lib/evaluate/fold.cc

@@ -545,6 +545,30 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
   return Expr<T>{std::move(funcRef)};
 }
 
+// TODO pmk rm
+template<typename RESULT, typename TO, typename FROM>
+Expr<RESULT> SIGN(
+    FoldingContext &context, const Scalar<TO> &to, const Scalar<FROM> &from) {
+  bool isNegative{false};
+  if constexpr (FROM::category == TypeCategory::Integer) {
+    isNegative = from.IsNegative();
+  } else {
+    static_assert(FROM::category == TypeCategory::Real);
+    isNegative = from.IsSignBitSet();
+  }
+  if constexpr (TO::category == TypeCategory::Integer) {
+    auto result{to.SIGN(isNegative)};
+    if (result.overflow) {
+      context.messages().Say(
+          "SIGN() folding overflows integer(kind=%d)"_en_US, TO::kind);
+    }
+    return Expr<RESULT>{Constant<RESULT>{std::move(result.value)}};
+  } else {
+    static_assert(TO::category == TypeCategory::Real);
+    return Expr<RESULT>{Constant<RESULT>{to.SIGN(isNegative)}};
+  }
+}
+
 template<int KIND>
 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
     FoldingContext &context,
@@ -837,7 +861,16 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
       }
     }
   } else if (name == "sign") {
-    // TODO pmk
+    return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
+        ScalarFunc<T, T, T>(
+            [&context](const Scalar<T> &j, const Scalar<T> &k) -> Scalar<T> {
+              typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
+              if (result.overflow) {
+                context.messages().Say(
+                    "sign(integer(kind=%d)) folding overflowed"_en_US, KIND);
+              }
+              return result.value;
+            }));
   } else if (name == "size") {
     if (auto shape{GetShape(context, args[0])}) {
       if (auto &dimArg{args[1]}) {  // DIM= is present, get one extent
@@ -1008,7 +1041,8 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
       return ToReal<KIND>(context, std::move(*expr));
     }
   } else if (name == "sign") {
-    // TODO pmk
+    return FoldElementalIntrinsic<T, T, T>(
+        context, std::move(funcRef), &Scalar<T>::SIGN);
   } else if (name == "tiny") {
     return Expr<T>{Scalar<T>::TINY()};
   }

flang/lib/evaluate/integer.h

@@ -774,17 +774,20 @@ class Integer {
     }
   }
 
-  constexpr ValueWithOverflow SIGN(const Integer &sign) const {
-    bool goNegative{sign.IsNegative()};
-    if (goNegative == IsNegative()) {
+  constexpr ValueWithOverflow SIGN(bool toNegative) const {
+    if (toNegative == IsNegative()) {
       return {*this, false};
-    } else if (goNegative) {
+    } else if (toNegative) {
       return Negate();
     } else {
       return ABS();
     }
   }
 
+  constexpr ValueWithOverflow SIGN(const Integer &sign) const {
+    return SIGN(sign.IsNegative());
+  }
+
   constexpr Product MultiplyUnsigned(const Integer &y) const {
     Part product[2 * parts]{};  // little-endian full product
     for (int j{0}; j < parts; ++j) {

flang/lib/evaluate/real.h

@@ -65,11 +65,12 @@ template<typename WORD, int PREC, bool IMPLICIT_MSB = true> class Real {
   }
 
   // TODO: ANINT, CEILING, FLOOR, DIM, MAX, MIN, DPROD, FRACTION,
-  // INT/NINT, NEAREST, OUT_OF_RANGE, DIGITS,
-  // RRSPACING/SPACING, SCALE, SET_EXPONENT, SIGN
+  // INT/NINT, NEAREST, OUT_OF_RANGE,
+  // RRSPACING/SPACING, SCALE, SET_EXPONENT
 
+  constexpr bool IsSignBitSet() const { return word_.BTEST(bits - 1); }
   constexpr bool IsNegative() const {
-    return !IsNotANumber() && word_.BTEST(bits - 1);
+    return !IsNotANumber() && IsSignBitSet();
   }
   constexpr bool IsNotANumber() const {
     return Exponent() == maxExponent && !GetSignificand().IsZero();
@@ -94,6 +95,14 @@ template<typename WORD, int PREC, bool IMPLICIT_MSB = true> class Real {
   constexpr Real ABS() const {  // non-arithmetic, no flags returned
     return {word_.IBCLR(bits - 1)};
   }
+  constexpr Real SetSign(bool toNegative) const {  // non-arithmetic
+    if (toNegative) {
+      return {word_.IBSET(bits - 1)};
+    } else {
+      return ABS();
+    }
+  }
+  constexpr Real SIGN(const Real &x) const { return SetSign(x.IsSignBitSet()); }
 
   constexpr Real Negate() const { return {word_.IEOR(word_.MASKL(1))}; }
 

flang/test/evaluate/folding02.f90

@@ -39,6 +39,9 @@ module m
   real(kind=4), parameter :: exp_##name##_r4 = expected; \
   logical, parameter :: test_##name##_r4 = abs(res_##name##_r4 - exp_##name##_r4).LE.(eps4)
 
+  logical, parameter :: test_sign_i4 = sign(1_4,2_4) == 1_4 .and. sign(1_4,-3_4) == -1_4
+  logical, parameter :: test_sign_i8 = sign(1_8,2_8) == 1_8 .and. sign(1_8,-3_8) == -1_8
+
   logical, parameter :: test_abs_r4 = abs(-2._4).EQ.(2._4)
   TEST_R4(acos, acos(0.5_4), 1.0471975803375244140625_4)
   TEST_R4(acosh, acosh(1.5_4), 0.96242368221282958984375_4)
@@ -61,6 +64,7 @@ module m
   TEST_R4(log_gamma, log_gamma(3.5_4), 1.20097362995147705078125_4)
   TEST_R4(mod, mod(-8.1_4, 5._4), (-3.1000003814697265625_4))
   TEST_R4(real, real(z'3f800000'), 1._4)
+  logical, parameter :: test_sign_r4 = sign(1._4,2._4) == 1._4 .and. sign(1._4,-2._4) == -1._4
   TEST_R4(sin, sin(1.6_4), 0.99957358837127685546875_4)
   TEST_R4(sinh, sinh(0.9_4), 1.0265166759490966796875_4)
   TEST_R4(sqrt, sqrt(1.1_4), 1.0488088130950927734375_4)
@@ -114,6 +118,7 @@ module m
   TEST_R8(mod, mod(-8.1_8, 5._8), &
     (-3.0999999999999996447286321199499070644378662109375_8))
   TEST_R8(real, real(z'3ff0000000000000',8), 1._8)
+  logical, parameter :: test_sign_r8 = sign(1._8,2._8) == 1._8 .and. sign(1._8,-2._8) == -1._8
   TEST_R8(sin, sin(1.6_8), &
     0.99957360304150510987852840116829611361026763916015625_8)
   TEST_R8(sinh, sinh(0.9_8), &