diff options
| -rw-r--r-- | gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/ieee/signaling_2.f90 | 70 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c | 8 | ||||
| -rw-r--r-- | libgfortran/ieee/ieee_arithmetic.F90 | 284 | ||||
| -rw-r--r-- | libgfortran/ieee/ieee_helper.c | 74 | ||||
| -rwxr-xr-x | libgfortran/mk-kinds-h.sh | 7 |
6 files changed, 203 insertions, 252 deletions
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 index c3ffffc..a596504 100644 --- 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 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 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 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)" |