[flang] Define missing & needed IEEE_ARITHMETIC symbols

[klausler]

Summary

Define IEEE_IS_NAN, IEEE_IS_FINITE, & IEEE_REM.

[jeanPerier]

LGTM

flang/include/flang/Evaluate/real.h

return Exponent() == maxExponent &&
         GetSignificand().BTEST(significandBits - 1);
   }
   constexpr bool IsSignalingNaN() const {
     return IsNotANumber() && !GetSignificand().BTEST(significandBits - 1);
   }
   constexpr bool IsInfinite() const {
     return Exponent() == maxExponent && GetSignificand().IsZero();
   }
+  constexpr bool IsFinite() const { return Exponent() != maxExponent; }
   constexpr bool IsZero() const {
     return Exponent() == 0 && GetSignificand().IsZero();
   }
   constexpr bool IsSubnormal() const {
     return Exponent() == 0 && !GetSignificand().IsZero();
   }
 
   constexpr Real ABS() const { // non-arithmetic, no flags returned

flang/lib/Evaluate/fold-logical.cpp

if (name == "bge") { // done in fptr declaration
       common::die("missing case to fold intrinsic function %s", name.c_str());
     }
     return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context,
         std::move(funcRef),
         ScalarFunc<T, LargestInt, LargestInt>(
             [&fptr](const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
               return Scalar<T>{std::invoke(fptr, i, j)};
             }));
-  } else if (name == "isnan") {
+  } else if (name == "isnan" || name == "__builtin_ieee_is_nan") {
     // A warning about an invalid argument is discarded from converting
-    // the argument of isnan().
+    // the argument of isnan() / IEEE_IS_NAN().
     auto restorer{context.messages().DiscardMessages()};
     using DefaultReal = Type<TypeCategory::Real, 4>;
     return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
         ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
           return Scalar<T>{x.IsNotANumber()};
         }));
   } else if (name == "is_contiguous") {
     if (args.at(0)) {

flang/lib/Evaluate/intrinsics.cpp

// NULL() is a special case handled in Probe() below
         {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array},
             {"field", SameType, Rank::conformable}},
         SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
     {"verify",
         {{"string", SameChar}, {"set", SameChar},
             {"back", AnyLogical, Rank::elemental, Optionality::optional},
             DefaultingKIND},
         KINDInt},
+    {"__builtin_ieee_is_nan", {{"a", AnyFloating}}, DefaultLogical},
     {"__builtin_ieee_selected_real_kind", // alias for selected_real_kind
         {{"p", AnyInt, Rank::scalar},
             {"r", AnyInt, Rank::scalar, Optionality::optional},
             {"radix", AnyInt, Rank::scalar, Optionality::optional}},
         DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"__builtin_ieee_support_datatype",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},

flang/module/__fortran_builtins.f90

module __Fortran_builtins
   end type
 
   type :: __builtin_team_type
     integer(kind=int64) :: __id
   end type
 
   procedure(type(__builtin_c_ptr)) :: __builtin_c_loc
 
+  intrinsic :: __builtin_ieee_is_nan
   intrinsic :: __builtin_ieee_selected_real_kind
   intrinsic :: __builtin_ieee_support_datatype, &
     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
     __builtin_ieee_support_inf, __builtin_ieee_support_io, &
     __builtin_ieee_support_nan, __builtin_ieee_support_sqrt, &
     __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
     __builtin_ieee_support_underflow_control
 
 end module

flang/module/ieee_arithmetic.f90

 !===-- module/ieee_arithmetic.f90 ------------------------------------------===!
 !
 ! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 ! See https://llvm.org/LICENSE.txt for license information.
 ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 !
 !===------------------------------------------------------------------------===!
 
 ! See Fortran 2018, clause 17.2
 module ieee_arithmetic
 
   use __Fortran_builtins, only: &
+    ieee_is_nan => __builtin_ieee_is_nan, &
+    ieee_selected_real_kind => __builtin_ieee_selected_real_kind, &
     ieee_support_datatype => __builtin_ieee_support_datatype, &
     ieee_support_denormal => __builtin_ieee_support_denormal, &
     ieee_support_divide => __builtin_ieee_support_divide, &
     ieee_support_inf => __builtin_ieee_support_inf, &
     ieee_support_io => __builtin_ieee_support_io, &
     ieee_support_nan => __builtin_ieee_support_nan, &
     ieee_support_sqrt => __builtin_ieee_support_sqrt, &
     ieee_support_standard => __builtin_ieee_support_standard, &
     ieee_support_subnormal => __builtin_ieee_support_subnormal, &
-    ieee_support_underflow_control => __builtin_ieee_support_underflow_control, &
-    ieee_selected_real_kind => __builtin_ieee_selected_real_kind
+    ieee_support_underflow_control => __builtin_ieee_support_underflow_control
+
+  implicit none
 
   type :: ieee_class_type
     private
     integer(kind=1) :: which = 0
   end type ieee_class_type
 
   type(ieee_class_type), parameter :: &
     ieee_signaling_nan = ieee_class_type(1), &
module ieee_arithmetic
   interface operator(==)
     module procedure class_eq
     module procedure round_eq
   end interface operator(==)
   interface operator(/=)
     module procedure class_ne
     module procedure round_ne
   end interface operator(/=)
+  private :: class_eq, class_ne, round_eq, round_ne
 
   ! See Fortran 2018, 17.10 & 17.11
-  interface ieee_class
-    module procedure ieee_class_a2
-    module procedure ieee_class_a3
-    module procedure ieee_class_a4
-    module procedure ieee_class_a8
-    module procedure ieee_class_a10
-    module procedure ieee_class_a16
-  end interface ieee_class
-
-  interface ieee_copy_sign
-    module procedure ieee_copy_sign_a2
-    module procedure ieee_copy_sign_a3
-    module procedure ieee_copy_sign_a4
-    module procedure ieee_copy_sign_a8
-    module procedure ieee_copy_sign_a10
-    module procedure ieee_copy_sign_a16
-  end interface ieee_copy_sign
+  generic :: ieee_class => ieee_class_a2, ieee_class_a3, ieee_class_a4, ieee_class_a8, ieee_class_a10, ieee_class_a16
+  private :: ieee_class_a2, ieee_class_a3, ieee_class_a4, ieee_class_a8, ieee_class_a10, ieee_class_a16
+
+  generic :: ieee_copy_sign => ieee_copy_sign_a2, ieee_copy_sign_a3, ieee_copy_sign_a4, ieee_copy_sign_a8, ieee_copy_sign_a10, ieee_copy_sign_a16
+  private :: ieee_copy_sign_a2, ieee_copy_sign_a3, ieee_copy_sign_a4, ieee_copy_sign_a8, ieee_copy_sign_a10, ieee_copy_sign_a16
+
+  generic :: ieee_is_finite => ieee_is_finite_a2, ieee_is_finite_a3, ieee_is_finite_a4, ieee_is_finite_a8, ieee_is_finite_a10, ieee_is_finite_a16
+  private :: ieee_is_finite_a2, ieee_is_finite_a3, ieee_is_finite_a4, ieee_is_finite_a8, ieee_is_finite_a10, ieee_is_finite_a16
+
+  generic :: ieee_rem => &
+    ieee_rem_a2_a2, ieee_rem_a2_a3, ieee_rem_a2_a4, ieee_rem_a2_a8, ieee_rem_a2_a10, ieee_rem_a2_a16, &
+    ieee_rem_a3_a2, ieee_rem_a3_a3, ieee_rem_a3_a4, ieee_rem_a3_a8, ieee_rem_a3_a10, ieee_rem_a3_a16, &
+    ieee_rem_a4_a2, ieee_rem_a4_a3, ieee_rem_a4_a4, ieee_rem_a4_a8, ieee_rem_a4_a10, ieee_rem_a4_a16, &
+    ieee_rem_a8_a2, ieee_rem_a8_a3, ieee_rem_a8_a4, ieee_rem_a8_a8, ieee_rem_a8_a10, ieee_rem_a8_a16, &
+    ieee_rem_a10_a2, ieee_rem_a10_a3, ieee_rem_a10_a4, ieee_rem_a10_a8, ieee_rem_a10_a10, ieee_rem_a10_a16, &
+    ieee_rem_a16_a2, ieee_rem_a16_a3, ieee_rem_a16_a4, ieee_rem_a16_a8, ieee_rem_a16_a10, ieee_rem_a16_a16
+  private :: &
+    ieee_rem_a2_a2, ieee_rem_a2_a3, ieee_rem_a2_a4, ieee_rem_a2_a8, ieee_rem_a2_a10, ieee_rem_a2_a16, &
+    ieee_rem_a3_a2, ieee_rem_a3_a3, ieee_rem_a3_a4, ieee_rem_a3_a8, ieee_rem_a3_a10, ieee_rem_a3_a16, &
+    ieee_rem_a4_a2, ieee_rem_a4_a3, ieee_rem_a4_a4, ieee_rem_a4_a8, ieee_rem_a4_a10, ieee_rem_a4_a16, &
+    ieee_rem_a8_a2, ieee_rem_a8_a3, ieee_rem_a8_a4, ieee_rem_a8_a8, ieee_rem_a8_a10, ieee_rem_a8_a16, &
+    ieee_rem_a10_a2, ieee_rem_a10_a3, ieee_rem_a10_a4, ieee_rem_a10_a8, ieee_rem_a10_a10, ieee_rem_a10_a16, &
+    ieee_rem_a16_a2, ieee_rem_a16_a3, ieee_rem_a16_a4, ieee_rem_a16_a8, ieee_rem_a16_a10, ieee_rem_a16_a16
 
   generic :: ieee_support_rounding => ieee_support_rounding_, &
     ieee_support_rounding_2, ieee_support_rounding_3, &
     ieee_support_rounding_4, ieee_support_rounding_8, &
     ieee_support_rounding_10, ieee_support_rounding_16
   private :: ieee_support_rounding_, &
     ieee_support_rounding_2, ieee_support_rounding_3, &
     ieee_support_rounding_4, ieee_support_rounding_8, &
#define _COPYSIGN(RKIND,IKIND,BITS) \
   _COPYSIGN(2,2,16)
   _COPYSIGN(3,2,16)
   _COPYSIGN(4,4,32)
   _COPYSIGN(8,8,64)
   _COPYSIGN(10,16,80)
   _COPYSIGN(16,16,128)
 #undef _COPYSIGN
 
+#define _IS_FINITE(KIND) \
+  elemental function ieee_is_finite_a##KIND(x) result(res); \
+    real(kind=KIND), intent(in) :: x; \
+    logical :: res; \
+    type(ieee_class_type) :: classification; \
+    classification = ieee_class(x); \
+    res = classification == ieee_negative_zero .or. classification == ieee_positive_zero \
+     .or. classification == ieee_negative_denormal .or. classification == ieee_positive_denormal \
+     .or. classification == ieee_negative_normal .or. classification == ieee_positive_normal; \
+  end function
+  _IS_FINITE(2)
+  _IS_FINITE(3)
+  _IS_FINITE(4)
+  _IS_FINITE(8)
+  _IS_FINITE(10)
+  _IS_FINITE(16)
+#undef _IS_FINITE
+
+! TODO: handle edge cases from 17.11.31
+#define _REM(XKIND,YKIND) \
+  elemental function ieee_rem_a##XKIND##_a##YKIND(x, y) result(res); \
+    real(kind=XKIND), intent(in) :: x; \
+    real(kind=YKIND), intent(in) :: y; \
+    integer, parameter :: rkind = max(XKIND, YKIND); \
+    real(kind=rkind) :: res, tmp; \
+    tmp = anint(real(x, kind=rkind) / y); \
+    res = x - y * tmp; \
+  end function
+  _REM(2,2)
+  _REM(2,3)
+  _REM(2,4)
+  _REM(2,8)
+  _REM(2,10)
+  _REM(2,16)
+  _REM(3,2)
+  _REM(3,3)
+  _REM(3,4)
+  _REM(3,8)
+  _REM(3,10)
+  _REM(3,16)
+  _REM(4,2)
+  _REM(4,3)
+  _REM(4,4)
+  _REM(4,8)
+  _REM(4,10)
+  _REM(4,16)
+  _REM(8,2)
+  _REM(8,3)
+  _REM(8,4)
+  _REM(8,8)
+  _REM(8,10)
+  _REM(8,16)
+  _REM(10,2)
+  _REM(10,3)
+  _REM(10,4)
+  _REM(10,8)
+  _REM(10,10)
+  _REM(10,16)
+  _REM(16,2)
+  _REM(16,3)
+  _REM(16,4)
+  _REM(16,8)
+  _REM(16,10)
+  _REM(16,16)
+#undef _REM
+
   pure logical function ieee_support_rounding_(round_type)
     type(ieee_round_type), intent(in) :: round_type
     ieee_support_rounding_ = .true.
   end function
   pure logical function ieee_support_rounding_2(round_type,x)
     type(ieee_round_type), intent(in) :: round_type
     real(kind=2), intent(in) :: x
     ieee_support_rounding_2 = .true.

flang/runtime/numeric.h

CppTypeFor<TypeCategory::Real, 4> RTNAME(Fraction4)(
     CppTypeFor<TypeCategory::Real, 4>);
 CppTypeFor<TypeCategory::Real, 8> RTNAME(Fraction8)(
     CppTypeFor<TypeCategory::Real, 8>);
 CppTypeFor<TypeCategory::Real, 10> RTNAME(Fraction10)(
     CppTypeFor<TypeCategory::Real, 10>);
 CppTypeFor<TypeCategory::Real, 16> RTNAME(Fraction16)(
     CppTypeFor<TypeCategory::Real, 16>);
 
+// ISNAN / IEEE_IS_NAN
+bool RTNAME(IsNaN4)(CppTypeFor<TypeCategory::Real, 4>);
+bool RTNAME(IsNaN8)(CppTypeFor<TypeCategory::Real, 8>);
+bool RTNAME(IsNaN10)(CppTypeFor<TypeCategory::Real, 10>);
+bool RTNAME(IsNaN16)(CppTypeFor<TypeCategory::Real, 16>);
+
 // MOD & MODULO
 CppTypeFor<TypeCategory::Integer, 1> RTNAME(ModInteger1)(
     CppTypeFor<TypeCategory::Integer, 1>, CppTypeFor<TypeCategory::Integer, 1>);
 CppTypeFor<TypeCategory::Integer, 2> RTNAME(ModInteger2)(
     CppTypeFor<TypeCategory::Integer, 2>, CppTypeFor<TypeCategory::Integer, 2>);
 CppTypeFor<TypeCategory::Integer, 4> RTNAME(ModInteger4)(
     CppTypeFor<TypeCategory::Integer, 4>, CppTypeFor<TypeCategory::Integer, 4>);
 CppTypeFor<TypeCategory::Integer, 8> RTNAME(ModInteger8)(

flang/runtime/numeric.cpp

 }
 #elif LONG_DOUBLE == 128
 CppTypeFor<TypeCategory::Real, 16> RTNAME(Fraction16)(
     CppTypeFor<TypeCategory::Real, 16> x) {
   return Fraction(x);
 }
 #endif
 
+bool RTNAME(IsFinite4)(CppTypeFor<TypeCategory::Real, 4> x) {
+  return std::isfinite(x);
+}
+bool RTNAME(IsFinite8)(CppTypeFor<TypeCategory::Real, 8> x) {
+  return std::isfinite(x);
+}
+#if LONG_DOUBLE == 80
+bool RTNAME(IsFinite10)(CppTypeFor<TypeCategory::Real, 10> x) {
+  return std::isfinite(x);
+}
+#elif LONG_DOUBLE == 128
+bool RTNAME(IsFinite16)(CppTypeFor<TypeCategory::Real, 16> x) {
+  return std::isfinite(x);
+}
+#endif
+
+bool RTNAME(IsNaN4)(CppTypeFor<TypeCategory::Real, 4> x) {
+  return std::isnan(x);
+}
+bool RTNAME(IsNaN8)(CppTypeFor<TypeCategory::Real, 8> x) {
+  return std::isnan(x);
+}
+#if LONG_DOUBLE == 80
+bool RTNAME(IsNaN10)(CppTypeFor<TypeCategory::Real, 10> x) {
+  return std::isnan(x);
+}
+#elif LONG_DOUBLE == 128
+bool RTNAME(IsNaN16)(CppTypeFor<TypeCategory::Real, 16> x) {
+  return std::isnan(x);
+}
+#endif
+
 CppTypeFor<TypeCategory::Integer, 1> RTNAME(ModInteger1)(
     CppTypeFor<TypeCategory::Integer, 1> x,
     CppTypeFor<TypeCategory::Integer, 1> p) {
   return IntMod<false>(x, p);
 }
 CppTypeFor<TypeCategory::Integer, 2> RTNAME(ModInteger2)(
     CppTypeFor<TypeCategory::Integer, 2> x,
     CppTypeFor<TypeCategory::Integer, 2> p) {

flang/unittests/RuntimeGTest/Numeric.cpp

TEST(Numeric, Fraction) {
   EXPECT_EQ(RTNAME(Fraction4)(Real<4>{0}), 0);
   EXPECT_EQ(RTNAME(Fraction8)(Real<8>{3.0}), 0.75);
   EXPECT_TRUE(
       std::isnan(RTNAME(Fraction4)(std::numeric_limits<Real<4>>::infinity())));
   EXPECT_TRUE(
       std::isnan(RTNAME(Fraction8)(std::numeric_limits<Real<8>>::quiet_NaN())));
 }
 
+TEST(Numeric, IsNaN) {
+  EXPECT_FALSE(RTNAME(IsNaN4)(Real<4>{0}));
+  EXPECT_FALSE(RTNAME(IsNaN8)(std::numeric_limits<Real<8>>::infinity()));
+  EXPECT_TRUE(RTNAME(IsNaN8)(std::numeric_limits<Real<8>>::quiet_NaN()));
+}
+
 TEST(Numeric, Mod) {
   EXPECT_EQ(RTNAME(ModInteger1)(Int<1>{8}, Int<1>(5)), 3);
   EXPECT_EQ(RTNAME(ModInteger4)(Int<4>{-8}, Int<4>(5)), -3);
   EXPECT_EQ(RTNAME(ModInteger2)(Int<2>{8}, Int<2>(-5)), 3);
   EXPECT_EQ(RTNAME(ModInteger8)(Int<8>{-8}, Int<8>(-5)), -3);
   EXPECT_EQ(RTNAME(ModReal4)(Real<4>{8.0}, Real<4>(5.0)), 3.0);
   EXPECT_EQ(RTNAME(ModReal4)(Real<4>{-8.0}, Real<4>(5.0)), -3.0);
   EXPECT_EQ(RTNAME(ModReal8)(Real<8>{8.0}, Real<8>(-5.0)), 3.0);