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
