Ping.
On Mon, Dec 24, 2018 at 11:59:50AM -0800, Steve Kargl wrote:
> All,
>
> The IEEE modules and -ffpe-trap are to some extent orthogonal
> features of gfortran. Unfortunately, some users have the
> expectation of using -ffpe-trap for debugging while also using only
> some of the mechanisms provided by the IEEE modules. For example,
>
> % t.f90
> program test
> use, intrinsic :: ieee_arithmetic
> real :: inf
> inf = ieee_value(inf, ieee_positive_inf)
> end program test
> % gfc8 -o z -ffpe-trap=overflow t.f90 && ./z
> Floating exception (core dumped)
>
> The correct use of the module would be along the lines of
>
> program test
> use, intrinsic :: ieee_arithmetic
> real :: inf
> logical h
> call ieee_get_halting_mode(ieee_overflow, h) ! store halting mode
> call ieee_set_halting_mode(ieee_overflow, .false.) ! no halting
> inf = ieee_value(inf, ieee_positive_inf)
> call ieee_set_halting_mode(ieee_overflow, h) ! restore halting
> mode
> end program test
>
> Technically (as I have done in the patch), the user should also
> use 'ieee_support_halting(ieee_overflow)', but that's just a detail.
>
> Now, IEEE_VALUE() is specifically included in the Fortran standard
> to allow it to provide qNaN, sNaN, +inf, and -inf (among a few other
> questionable constants). The attached patch allows gfortran to
> generate an executable that does not abort with SIGFPE.
>
> 2018-12-24 Steven G. Kargl <ka...@gcc.gnu.org>
>
> PR fortran/88342
> * ieee/ieee_arithmetic.F90: Prevent exceptions in IEEE_VALUE if
> -ffpe-trap=invalid or -ffpe-trap=overflow is used.
>
> 2018-12-24 Steven G. Kargl <ka...@gcc.gnu.org>
>
> PR fortran/88342
> * gfortran.dg/ieee/ieee_10.f90: New test.
>
> Regression tested on i586-*-freebsd and x86_64-*-freebsd. OK to commit?
>
> --
> Steve
> 20170425 https://www.youtube.com/watch?v=VWUpyCsUKR4
> 20161221 https://www.youtube.com/watch?v=IbCHE-hONow
> Index: gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
> ===================================================================
> --- gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 (nonexistent)
> +++ gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 (working copy)
> @@ -0,0 +1,32 @@
> +! { dg-do run }
> +! { dg-options "-ffpe-trap=overflow,invalid" }
> +program foo
> +
> + use ieee_arithmetic
> +
> + implicit none
> +
> + real x
> + real(8) y
> +
> + 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
> +
> + x = ieee_value(x, ieee_positive_inf)
> + if (ieee_is_finite(x)) stop 3
> + 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
> + y = ieee_value(y, ieee_quiet_nan)
> + if (.not. ieee_is_nan(y)) stop 6
> +
> + y = ieee_value(y, ieee_positive_inf)
> + if (ieee_is_finite(y)) stop 7
> + y = ieee_value(y, ieee_negative_inf)
> + if (ieee_is_finite(y)) stop 8
> +
> +end program foo
> Index: libgfortran/ieee/ieee_arithmetic.F90
> ===================================================================
> --- libgfortran/ieee/ieee_arithmetic.F90 (revision 267415)
> +++ libgfortran/ieee/ieee_arithmetic.F90 (working copy)
> @@ -914,17 +914,39 @@ contains
>
> 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
> @@ -941,8 +963,15 @@ contains
> 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
> @@ -952,17 +981,39 @@ contains
>
> 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
> @@ -979,8 +1030,15 @@ contains
> 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
> @@ -991,17 +1049,39 @@ contains
>
> 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)
> - case (3) ! IEEE_NEGATIVE_INF
> + 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
> @@ -1018,8 +1098,15 @@ contains
> 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
> @@ -1032,17 +1119,39 @@ contains
>
> 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
> @@ -1059,8 +1168,15 @@ contains
> 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
--
Steve
20170425 https://www.youtube.com/watch?v=VWUpyCsUKR4
20161221 https://www.youtube.com/watch?v=IbCHE-hONow
