1 ! Implementation of the IEEE_EXCEPTIONS standard intrinsic module
2 ! Copyright (C) 2013-2023 Free Software Foundation, Inc.
3 ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
5 ! This file is part of the GNU Fortran runtime library (libgfortran).
7 ! Libgfortran is free software; you can redistribute it and/or
8 ! modify it under the terms of the GNU General Public
9 ! License as published by the Free Software Foundation; either
10 ! version 3 of the License, or (at your option) any later version.
12 ! Libgfortran is distributed in the hope that it will be useful,
13 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ! GNU General Public License for more details.
17 ! Under Section 7 of GPL version 3, you are granted additional
18 ! permissions described in the GCC Runtime Library Exception, version
19 ! 3.1, as published by the Free Software Foundation.
21 ! You should have received a copy of the GNU General Public License and
22 ! a copy of the GCC Runtime Library Exception along with this program;
23 ! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 ! <http://www.gnu.org/licenses/>. */
28 #include "c99_protos.inc"
29 #include "fpu-target.inc"
31 module IEEE_EXCEPTIONS
36 ! Derived types and named constants
38 type, public :: IEEE_FLAG_TYPE
43 type(IEEE_FLAG_TYPE), parameter, public :: &
44 IEEE_INVALID = IEEE_FLAG_TYPE(GFC_FPE_INVALID), &
45 IEEE_OVERFLOW = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), &
46 IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), &
47 IEEE_UNDERFLOW = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), &
48 IEEE_INEXACT = IEEE_FLAG_TYPE(GFC_FPE_INEXACT)
50 type(IEEE_FLAG_TYPE), parameter, public :: &
51 IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], &
52 IEEE_ALL(5) = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ]
54 type, public :: IEEE_STATUS_TYPE
56 character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
59 type, public :: IEEE_MODES_TYPE
66 interface IEEE_SUPPORT_FLAG
67 module procedure IEEE_SUPPORT_FLAG_4, &
68 IEEE_SUPPORT_FLAG_8, &
69 #ifdef HAVE_GFC_REAL_10
70 IEEE_SUPPORT_FLAG_10, &
72 #ifdef HAVE_GFC_REAL_16
73 IEEE_SUPPORT_FLAG_16, &
75 IEEE_SUPPORT_FLAG_NOARG
76 end interface IEEE_SUPPORT_FLAG
78 public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
79 public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
80 public :: IEEE_SET_FLAG, IEEE_GET_FLAG
81 public :: IEEE_SET_STATUS, IEEE_GET_STATUS
82 public :: IEEE_SET_MODES, IEEE_GET_MODES
86 ! Fortran 2018: Saving and restoring floating-point modes
87 ! (rounding modes, underflow mode, and halting mode)
89 ! For now, we only have one rounding mode for all kinds.
90 ! Some targets could optimize getting/setting all modes at once, but for now
91 ! we make three calls. This code must be kept in sync with:
92 ! - IEEE_{GET,SET}_ROUNDING_MODE
93 ! - IEEE_{GET,SET}_UNDERFLOW_MODE
94 ! - IEEE_{GET,SET}_HALTING_MODE
96 subroutine IEEE_GET_MODES (MODES)
98 type(IEEE_MODES_TYPE), intent(out) :: MODES
101 integer function helper_rounding() &
102 bind(c, name="_gfortrani_get_fpu_rounding_mode")
104 integer function helper_underflow() &
105 bind(c, name="_gfortrani_get_fpu_underflow_mode")
107 pure integer function helper_halting() &
108 bind(c, name="_gfortrani_get_fpu_trap_exceptions")
112 MODES%rounding = helper_rounding()
113 MODES%underflow = helper_underflow()
114 MODES%halting = helper_halting()
117 subroutine IEEE_SET_MODES (MODES)
119 type(IEEE_MODES_TYPE), intent(in) :: MODES
122 subroutine helper_rounding(val) &
123 bind(c, name="_gfortrani_set_fpu_rounding_mode")
124 integer, value :: val
126 subroutine helper_underflow(val) &
127 bind(c, name="_gfortrani_set_fpu_underflow_mode")
128 integer, value :: val
130 pure subroutine helper_halting(trap, notrap) &
131 bind(c, name="_gfortrani_set_fpu_trap_exceptions")
132 integer, intent(in), value :: trap, notrap
136 call helper_rounding(MODES%rounding)
137 call helper_underflow(MODES%underflow)
138 call helper_halting(MODES%halting, NOT(MODES%halting))
141 ! Saving and restoring floating-point status
143 subroutine IEEE_GET_STATUS (STATUS_VALUE)
145 type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
148 subroutine helper(ptr) &
149 bind(c, name="_gfortrani_get_fpu_state")
150 use, intrinsic :: iso_c_binding, only : c_char
151 character(kind=c_char) :: ptr(*)
155 call helper(STATUS_VALUE%hidden)
158 subroutine IEEE_SET_STATUS (STATUS_VALUE)
160 type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
163 subroutine helper(ptr) &
164 bind(c, name="_gfortrani_set_fpu_state")
165 use, intrinsic :: iso_c_binding, only : c_char
166 character(kind=c_char) :: ptr(*)
170 call helper(STATUS_VALUE%hidden)
173 ! Getting and setting flags
175 elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
177 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
178 logical, intent(out) :: FLAG_VALUE
181 pure integer function helper() &
182 bind(c, name="_gfortrani_get_fpu_except_flags")
186 FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
189 elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
191 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
192 logical, intent(in) :: FLAG_VALUE
195 pure subroutine helper(set, clear) &
196 bind(c, name="_gfortrani_set_fpu_except_flags")
197 integer, intent(in), value :: set, clear
202 call helper(FLAG%hidden, 0)
204 call helper(0, FLAG%hidden)
208 ! Querying and changing the halting mode
210 elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
212 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
213 logical, intent(out) :: HALTING
216 pure integer function helper() &
217 bind(c, name="_gfortrani_get_fpu_trap_exceptions")
221 HALTING = (IAND(helper(), FLAG%hidden) /= 0)
224 elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
226 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
227 logical, intent(in) :: HALTING
230 pure subroutine helper(trap, notrap) &
231 bind(c, name="_gfortrani_set_fpu_trap_exceptions")
232 integer, intent(in), value :: trap, notrap
237 call helper(FLAG%hidden, 0)
239 call helper(0, FLAG%hidden)
245 pure logical function IEEE_SUPPORT_HALTING (FLAG)
247 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
250 pure integer function helper(flag) &
251 bind(c, name="_gfortrani_support_fpu_trap")
252 integer, intent(in), value :: flag
256 IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
259 pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
261 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
264 pure integer function helper(flag) &
265 bind(c, name="_gfortrani_support_fpu_flag")
266 integer, intent(in), value :: flag
270 IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
273 pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
275 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
276 real(kind=4), intent(in) :: X
277 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
280 pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
282 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
283 real(kind=8), intent(in) :: X
284 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
287 #ifdef HAVE_GFC_REAL_10
288 pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
290 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
291 real(kind=10), intent(in) :: X
292 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
296 #ifdef HAVE_GFC_REAL_16
297 pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
299 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
300 real(kind=16), intent(in) :: X
301 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
305 end module IEEE_EXCEPTIONS