Fortran: allow IEEE_VALUE to correctly return signaling NaNs

I moved the library implementation of IEEE_VALUE in libgfortran from
Fortran to C code, which gives us access to GCC's built-ins for NaN generation
(both quiet and signalling). It will be perform better than the current
Fortran implementation.

libgfortran/ChangeLog:

	PR fortran/82207
	* mk-kinds-h.sh: Add values for TINY.
	* ieee/ieee_arithmetic.F90: Call C helper functions for
	IEEE_VALUE.
	* ieee/ieee_helper.c: New functions ieee_value_helper_N for each
	floating-point type.

gcc/testsuite/ChangeLog:

	PR fortran/82207
	* gfortran.dg/ieee/ieee_10.f90: Do not create signaling NaNs.
	* gfortran.dg/ieee/signaling_2.f90: New test.
	* gfortran.dg/ieee/signaling_2_c.c: New file.

diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
index c3ffffcb24d43ac78414b6b91bc04bd94c089a15..a596504ae1e4a2b8f9cb93022a2d4c63fa403147 100644 (file)
--- a/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
@@ -12,8 +12,10 @@ program foo
    real x
    real(8) y
 
-   x = ieee_value(x, ieee_signaling_nan)
-   if (.not. ieee_is_nan(x)) stop 1
+   ! At this point it is unclear what the behavior should be
+   ! for -ffpe-trap=invalid with a signaling NaN
+   !x = ieee_value(x, ieee_signaling_nan)
+   !if (.not. ieee_is_nan(x)) stop 1
    x = ieee_value(x, ieee_quiet_nan)
    if (.not. ieee_is_nan(x)) stop 2
 
@@ -22,8 +24,10 @@ program foo
    x = ieee_value(x, ieee_negative_inf)
    if (ieee_is_finite(x)) stop 4
 
-   y = ieee_value(y, ieee_signaling_nan)
-   if (.not. ieee_is_nan(y)) stop 5
+   ! At this point it is unclear what the behavior should be
+   ! for -ffpe-trap=invalid with a signaling NaN
+   !y = ieee_value(y, ieee_signaling_nan)
+   !if (.not. ieee_is_nan(y)) stop 5
    y = ieee_value(y, ieee_quiet_nan)
    if (.not. ieee_is_nan(y)) stop 6
 

diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90 b/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90
new file mode 100644 (file)
index 0000000..e7e7a4a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-require-effective-target issignaling } */
+! { dg-additional-sources signaling_2_c.c }
+! { dg-additional-options "-w" }
+! the -w option is needed to make cc1 not report a warning for
+! the -fintrinsic-modules-path option passed by ieee.exp
+!
+program test
+  use, intrinsic :: iso_c_binding
+  use, intrinsic :: ieee_arithmetic
+  implicit none
+
+  interface
+    integer(kind=c_int) function isnansf (x) bind(c)
+      import :: c_float, c_int
+      real(kind=c_float), value :: x
+    end function
+
+    integer(kind=c_int) function isnans (x) bind(c)
+      import :: c_double, c_int
+      real(kind=c_double), value :: x
+    end function
+
+    integer(kind=c_int) function isnansl (x) bind(c)
+      import :: c_long_double, c_int
+      real(kind=c_long_double), value :: x
+    end function
+  end interface
+
+  real(kind=c_float) :: x
+  real(kind=c_double) :: y
+  real(kind=c_long_double) :: z
+
+  if (ieee_support_nan(x)) then
+    x = ieee_value(x, ieee_signaling_nan)
+    if (ieee_class(x) /= ieee_signaling_nan) stop 100
+    if (.not. ieee_is_nan(x)) stop 101
+    if (isnansf(x) /= 1) stop 102
+
+    x = ieee_value(x, ieee_quiet_nan)
+    if (ieee_class(x) /= ieee_quiet_nan) stop 103
+    if (.not. ieee_is_nan(x)) stop 104
+    if (isnansf(x) /= 0) stop 105
+  end if
+
+  if (ieee_support_nan(y)) then
+    y = ieee_value(y, ieee_signaling_nan)
+    if (ieee_class(y) /= ieee_signaling_nan) stop 100
+    if (.not. ieee_is_nan(y)) stop 101
+    if (isnans(y) /= 1) stop 102
+
+    y = ieee_value(y, ieee_quiet_nan)
+    if (ieee_class(y) /= ieee_quiet_nan) stop 103
+    if (.not. ieee_is_nan(y)) stop 104
+    if (isnans(y) /= 0) stop 105
+  end if
+
+  if (ieee_support_nan(z)) then
+    z = ieee_value(z, ieee_signaling_nan)
+    if (ieee_class(z) /= ieee_signaling_nan) stop 100
+    if (.not. ieee_is_nan(z)) stop 101
+    if (isnansl(z) /= 1) stop 102
+
+    z = ieee_value(z, ieee_quiet_nan)
+    if (ieee_class(z) /= ieee_quiet_nan) stop 103
+    if (.not. ieee_is_nan(z)) stop 104
+    if (isnansl(z) /= 0) stop 105
+  end if
+
+end program test

diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c b/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c
new file mode 100644 (file)
index 0000000..ea7fc04
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c
@@ -0,0 +1,8 @@
+#define _GNU_SOURCE
+#include <math.h>
+#include <float.h>
+
+int isnansf (float x)       { return issignaling (x) ? 1 : 0; }
+int isnans  (double x)      { return issignaling (x) ? 1 : 0; }
+int isnansl (long double x) { return issignaling (x) ? 1 : 0; }
+

diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 7e34660eb502b417e4ecc899f744c6746d80fc25..c8ef3e2faeb184bbe733669a9e6480acfc208663 100644 (file)
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -915,275 +915,63 @@ contains
   ! IEEE_VALUE
 
   elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
-
     real(kind=4), intent(in) :: X
     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
-    logical flag
-
-    select case (CLASS%hidden)
-      case (1)     ! IEEE_SIGNALING_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (2)     ! IEEE_QUIET_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (3)     ! IEEE_NEGATIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = (-res) * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case (4)     ! IEEE_NEGATIVE_NORMAL
-        res = -42
-      case (5)     ! IEEE_NEGATIVE_DENORMAL
-        res = -tiny(res)
-        res = res / 2
-      case (6)     ! IEEE_NEGATIVE_ZERO
-        res = 0
-        res = -res
-      case (7)     ! IEEE_POSITIVE_ZERO
-        res = 0
-      case (8)     ! IEEE_POSITIVE_DENORMAL
-        res = tiny(res)
-        res = res / 2
-      case (9)     ! IEEE_POSITIVE_NORMAL
-        res = 42
-      case (10)    ! IEEE_POSITIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = res * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case default ! IEEE_OTHER_VALUE, should not happen
-        res = 0
-     end select
+
+    interface
+      pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
+        use ISO_C_BINDING, only: C_INT
+        integer(kind=C_INT), value :: x
+      end function
+    end interface
+
+    res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
   end function
 
   elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
-
     real(kind=8), intent(in) :: X
     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
-    logical flag
-
-    select case (CLASS%hidden)
-      case (1)     ! IEEE_SIGNALING_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (2)     ! IEEE_QUIET_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (3)     ! IEEE_NEGATIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = (-res) * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case (4)     ! IEEE_NEGATIVE_NORMAL
-        res = -42
-      case (5)     ! IEEE_NEGATIVE_DENORMAL
-        res = -tiny(res)
-        res = res / 2
-      case (6)     ! IEEE_NEGATIVE_ZERO
-        res = 0
-        res = -res
-      case (7)     ! IEEE_POSITIVE_ZERO
-        res = 0
-      case (8)     ! IEEE_POSITIVE_DENORMAL
-        res = tiny(res)
-        res = res / 2
-      case (9)     ! IEEE_POSITIVE_NORMAL
-        res = 42
-      case (10)    ! IEEE_POSITIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = res * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case default ! IEEE_OTHER_VALUE, should not happen
-        res = 0
-     end select
+
+    interface
+      pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
+        use ISO_C_BINDING, only: C_INT
+        integer(kind=C_INT), value :: x
+      end function
+    end interface
+
+    res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
   end function
 
 #ifdef HAVE_GFC_REAL_10
   elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
-
     real(kind=10), intent(in) :: X
     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
-    logical flag
-
-    select case (CLASS%hidden)
-      case (1)     ! IEEE_SIGNALING_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (2)     ! IEEE_QUIET_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-     case (3)     ! IEEE_NEGATIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = (-res) * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case (4)     ! IEEE_NEGATIVE_NORMAL
-        res = -42
-      case (5)     ! IEEE_NEGATIVE_DENORMAL
-        res = -tiny(res)
-        res = res / 2
-      case (6)     ! IEEE_NEGATIVE_ZERO
-        res = 0
-        res = -res
-      case (7)     ! IEEE_POSITIVE_ZERO
-        res = 0
-      case (8)     ! IEEE_POSITIVE_DENORMAL
-        res = tiny(res)
-        res = res / 2
-      case (9)     ! IEEE_POSITIVE_NORMAL
-        res = 42
-      case (10)    ! IEEE_POSITIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = res * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case default ! IEEE_OTHER_VALUE, should not happen
-        res = 0
-     end select
+
+    interface
+      pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
+        use ISO_C_BINDING, only: C_INT
+        integer(kind=C_INT), value :: x
+      end function
+    end interface
+
+    res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
   end function
 
 #endif
 
 #ifdef HAVE_GFC_REAL_16
   elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
-
     real(kind=16), intent(in) :: X
     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
-    logical flag
-
-    select case (CLASS%hidden)
-      case (1)     ! IEEE_SIGNALING_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (2)     ! IEEE_QUIET_NAN
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_get_halting_mode(ieee_invalid, flag)
-           call ieee_set_halting_mode(ieee_invalid, .false.)
-        end if
-        res = -1
-        res = sqrt(res)
-        if (ieee_support_halting(ieee_invalid)) then
-           call ieee_set_halting_mode(ieee_invalid, flag)
-        end if
-      case (3)     ! IEEE_NEGATIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = (-res) * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case (4)     ! IEEE_NEGATIVE_NORMAL
-        res = -42
-      case (5)     ! IEEE_NEGATIVE_DENORMAL
-        res = -tiny(res)
-        res = res / 2
-      case (6)     ! IEEE_NEGATIVE_ZERO
-        res = 0
-        res = -res
-      case (7)     ! IEEE_POSITIVE_ZERO
-        res = 0
-      case (8)     ! IEEE_POSITIVE_DENORMAL
-        res = tiny(res)
-        res = res / 2
-      case (9)     ! IEEE_POSITIVE_NORMAL
-        res = 42
-      case (10)    ! IEEE_POSITIVE_INF
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_get_halting_mode(ieee_overflow, flag)
-           call ieee_set_halting_mode(ieee_overflow, .false.)
-        end if
-        res = huge(res)
-        res = res * res
-        if (ieee_support_halting(ieee_overflow)) then
-           call ieee_set_halting_mode(ieee_overflow, flag)
-        end if
-      case default ! IEEE_OTHER_VALUE, should not happen
-        res = 0
-     end select
+
+    interface
+      pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
+        use ISO_C_BINDING, only: C_INT
+        integer(kind=C_INT), value :: x
+      end function
+    end interface
+
+    res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
   end function
 #endif
 

diff --git a/libgfortran/ieee/ieee_helper.c b/libgfortran/ieee/ieee_helper.c
index 7a103df58f0448754443ad6b807b10a025826613..794ccec40ee44ba6fb3c989135256b4a9548f9e9 100644 (file)
--- a/libgfortran/ieee/ieee_helper.c
+++ b/libgfortran/ieee/ieee_helper.c
@@ -116,6 +116,80 @@ CLASSMACRO(16)
 #endif
 
 
+extern GFC_REAL_4 ieee_value_helper_4 (int);
+internal_proto(ieee_value_helper_4);
+
+extern GFC_REAL_8 ieee_value_helper_8 (int);
+internal_proto(ieee_value_helper_8);
+
+#ifdef HAVE_GFC_REAL_10
+extern GFC_REAL_10 ieee_value_helper_10 (int);
+internal_proto(ieee_value_helper_10);
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+extern GFC_REAL_16 ieee_value_helper_16 (int);
+internal_proto(ieee_value_helper_16);
+#endif
+
+
+#define VALUEMACRO(TYPE, SUFFIX) \
+  GFC_REAL_ ## TYPE ieee_value_helper_ ## TYPE (int type) \
+  { \
+    switch (type) \
+    { \
+      case IEEE_SIGNALING_NAN: \
+       return __builtin_nans ## SUFFIX (""); \
+   \
+      case IEEE_QUIET_NAN: \
+       return __builtin_nan ## SUFFIX (""); \
+   \
+      case IEEE_NEGATIVE_INF: \
+       return - __builtin_inf ## SUFFIX (); \
+   \
+      case IEEE_NEGATIVE_NORMAL: \
+       return -42; \
+   \
+      case IEEE_NEGATIVE_DENORMAL: \
+       return -(GFC_REAL_ ## TYPE ## _TINY) / 2; \
+   \
+      case IEEE_NEGATIVE_ZERO: \
+       return -(GFC_REAL_ ## TYPE) 0; \
+   \
+      case IEEE_POSITIVE_ZERO: \
+       return 0; \
+   \
+      case IEEE_POSITIVE_DENORMAL: \
+       return (GFC_REAL_ ## TYPE ## _TINY) / 2; \
+   \
+      case IEEE_POSITIVE_NORMAL: \
+       return 42; \
+   \
+      case IEEE_POSITIVE_INF: \
+       return __builtin_inf ## SUFFIX (); \
+   \
+      default: \
+       return 0; \
+    } \
+  }
+
+
+VALUEMACRO(4, f)
+VALUEMACRO(8, )
+
+#ifdef HAVE_GFC_REAL_10
+VALUEMACRO(10, l)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+# ifdef GFC_REAL_16_IS_FLOAT128
+VALUEMACRO(16, f128)
+# else
+VALUEMACRO(16, l)
+# endif
+#endif
+
+
 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
                     GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
                     GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)

diff --git a/libgfortran/mk-kinds-h.sh b/libgfortran/mk-kinds-h.sh
index 572878ce8912b0a0bb1308bc5fe097a2ff0d77f6..fb4232eb954410c704627a3a5e76da7ee34e81e5 100755 (executable)
--- a/libgfortran/mk-kinds-h.sh
+++ b/libgfortran/mk-kinds-h.sh
@@ -87,6 +87,12 @@ for k in $possible_real_kinds; do
                | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
     rm -f tmq$$.*
 
+    # Check for the value of TINY
+    echo "print *, tiny(0._$k) ; end" > tmq$$.f90
+    tiny=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
+               | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
+    rm -f tmq$$.*
+
     # Check for the value of DIGITS
     echo "print *, digits(0._$k) ; end" > tmq$$.f90
     digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
@@ -105,6 +111,7 @@ for k in $possible_real_kinds; do
     echo "#define HAVE_GFC_REAL_${k}"
     echo "#define HAVE_GFC_COMPLEX_${k}"
     echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}"
+    echo "#define GFC_REAL_${k}_TINY ${tiny}${suffix}"
     echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}"
     if [ "x$suffix" = "x" ]; then
       echo "#define GFC_REAL_${k}_LITERAL(X) (X)"