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.

3 files changed, 117 insertions, 248 deletions

diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 7e34660..c8ef3e2 100644
--- 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 7a103df..794ccec 100644
--- 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 572878c..fb4232e 100755
--- 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)"