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,
}
}
} 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
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()};
}
}
}
- 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) {
}
// 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();
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))}; }
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)
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)
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), &