|
111
|
1 ! Implementation of the IEEE_EXCEPTIONS standard intrinsic module
|
|
145
|
2 ! Copyright (C) 2013-2020 Free Software Foundation, Inc.
|
|
111
|
3 ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
|
|
4 !
|
|
|
5 ! This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
6 !
|
|
|
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.
|
|
|
11 !
|
|
|
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.
|
|
|
16 !
|
|
|
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.
|
|
|
20 !
|
|
|
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/>. */
|
|
|
25
|
|
|
26 #include "config.h"
|
|
|
27 #include "kinds.inc"
|
|
|
28 #include "c99_protos.inc"
|
|
|
29 #include "fpu-target.inc"
|
|
|
30
|
|
|
31 module IEEE_EXCEPTIONS
|
|
|
32
|
|
|
33 implicit none
|
|
|
34 private
|
|
|
35
|
|
|
36 ! Derived types and named constants
|
|
|
37
|
|
|
38 type, public :: IEEE_FLAG_TYPE
|
|
|
39 private
|
|
|
40 integer :: hidden
|
|
|
41 end type
|
|
|
42
|
|
|
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)
|
|
|
49
|
|
|
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 ]
|
|
|
53
|
|
|
54 type, public :: IEEE_STATUS_TYPE
|
|
|
55 private
|
|
|
56 character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
|
|
|
57 end type
|
|
|
58
|
|
|
59 interface IEEE_SUPPORT_FLAG
|
|
|
60 module procedure IEEE_SUPPORT_FLAG_4, &
|
|
|
61 IEEE_SUPPORT_FLAG_8, &
|
|
|
62 #ifdef HAVE_GFC_REAL_10
|
|
|
63 IEEE_SUPPORT_FLAG_10, &
|
|
|
64 #endif
|
|
|
65 #ifdef HAVE_GFC_REAL_16
|
|
|
66 IEEE_SUPPORT_FLAG_16, &
|
|
|
67 #endif
|
|
|
68 IEEE_SUPPORT_FLAG_NOARG
|
|
|
69 end interface IEEE_SUPPORT_FLAG
|
|
|
70
|
|
|
71 public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
|
|
|
72 public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
|
|
|
73 public :: IEEE_SET_FLAG, IEEE_GET_FLAG
|
|
|
74 public :: IEEE_SET_STATUS, IEEE_GET_STATUS
|
|
|
75
|
|
|
76 contains
|
|
|
77
|
|
|
78 ! Saving and restoring floating-point status
|
|
|
79
|
|
|
80 subroutine IEEE_GET_STATUS (STATUS_VALUE)
|
|
|
81 implicit none
|
|
|
82 type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
|
|
|
83
|
|
|
84 interface
|
|
|
85 subroutine helper(ptr) &
|
|
|
86 bind(c, name="_gfortrani_get_fpu_state")
|
|
|
87 use, intrinsic :: iso_c_binding, only : c_char
|
|
|
88 character(kind=c_char) :: ptr(*)
|
|
|
89 end subroutine
|
|
|
90 end interface
|
|
|
91
|
|
|
92 call helper(STATUS_VALUE%hidden)
|
|
|
93 end subroutine
|
|
|
94
|
|
|
95 subroutine IEEE_SET_STATUS (STATUS_VALUE)
|
|
|
96 implicit none
|
|
|
97 type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
|
|
|
98
|
|
|
99 interface
|
|
|
100 subroutine helper(ptr) &
|
|
|
101 bind(c, name="_gfortrani_set_fpu_state")
|
|
|
102 use, intrinsic :: iso_c_binding, only : c_char
|
|
|
103 character(kind=c_char) :: ptr(*)
|
|
|
104 end subroutine
|
|
|
105 end interface
|
|
|
106
|
|
|
107 call helper(STATUS_VALUE%hidden)
|
|
|
108 end subroutine
|
|
|
109
|
|
|
110 ! Getting and setting flags
|
|
|
111
|
|
|
112 elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
|
|
|
113 implicit none
|
|
|
114 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
115 logical, intent(out) :: FLAG_VALUE
|
|
|
116
|
|
|
117 interface
|
|
|
118 pure integer function helper() &
|
|
|
119 bind(c, name="_gfortrani_get_fpu_except_flags")
|
|
|
120 end function
|
|
|
121 end interface
|
|
|
122
|
|
|
123 FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
|
|
|
124 end subroutine
|
|
|
125
|
|
|
126 elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
|
|
|
127 implicit none
|
|
|
128 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
129 logical, intent(in) :: FLAG_VALUE
|
|
|
130
|
|
|
131 interface
|
|
|
132 pure subroutine helper(set, clear) &
|
|
|
133 bind(c, name="_gfortrani_set_fpu_except_flags")
|
|
|
134 integer, intent(in), value :: set, clear
|
|
|
135 end subroutine
|
|
|
136 end interface
|
|
|
137
|
|
|
138 if (FLAG_VALUE) then
|
|
|
139 call helper(FLAG%hidden, 0)
|
|
|
140 else
|
|
|
141 call helper(0, FLAG%hidden)
|
|
|
142 end if
|
|
|
143 end subroutine
|
|
|
144
|
|
|
145 ! Querying and changing the halting mode
|
|
|
146
|
|
|
147 elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
|
|
|
148 implicit none
|
|
|
149 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
150 logical, intent(out) :: HALTING
|
|
|
151
|
|
|
152 interface
|
|
|
153 pure integer function helper() &
|
|
|
154 bind(c, name="_gfortrani_get_fpu_trap_exceptions")
|
|
|
155 end function
|
|
|
156 end interface
|
|
|
157
|
|
|
158 HALTING = (IAND(helper(), FLAG%hidden) /= 0)
|
|
|
159 end subroutine
|
|
|
160
|
|
|
161 elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
|
|
|
162 implicit none
|
|
|
163 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
164 logical, intent(in) :: HALTING
|
|
|
165
|
|
|
166 interface
|
|
|
167 pure subroutine helper(trap, notrap) &
|
|
|
168 bind(c, name="_gfortrani_set_fpu_trap_exceptions")
|
|
|
169 integer, intent(in), value :: trap, notrap
|
|
|
170 end subroutine
|
|
|
171 end interface
|
|
|
172
|
|
|
173 if (HALTING) then
|
|
|
174 call helper(FLAG%hidden, 0)
|
|
|
175 else
|
|
|
176 call helper(0, FLAG%hidden)
|
|
|
177 end if
|
|
|
178 end subroutine
|
|
|
179
|
|
|
180 ! Querying support
|
|
|
181
|
|
|
182 pure logical function IEEE_SUPPORT_HALTING (FLAG)
|
|
|
183 implicit none
|
|
|
184 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
185
|
|
|
186 interface
|
|
|
187 pure integer function helper(flag) &
|
|
|
188 bind(c, name="_gfortrani_support_fpu_trap")
|
|
|
189 integer, intent(in), value :: flag
|
|
|
190 end function
|
|
|
191 end interface
|
|
|
192
|
|
|
193 IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
|
|
|
194 end function
|
|
|
195
|
|
|
196 pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
|
|
|
197 implicit none
|
|
|
198 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
199
|
|
|
200 interface
|
|
|
201 pure integer function helper(flag) &
|
|
|
202 bind(c, name="_gfortrani_support_fpu_flag")
|
|
|
203 integer, intent(in), value :: flag
|
|
|
204 end function
|
|
|
205 end interface
|
|
|
206
|
|
|
207 IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
|
|
|
208 end function
|
|
|
209
|
|
|
210 pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
|
|
|
211 implicit none
|
|
|
212 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
213 real(kind=4), intent(in) :: X
|
|
|
214 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
|
|
215 end function
|
|
|
216
|
|
|
217 pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
|
|
|
218 implicit none
|
|
|
219 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
220 real(kind=8), intent(in) :: X
|
|
|
221 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
|
|
222 end function
|
|
|
223
|
|
|
224 #ifdef HAVE_GFC_REAL_10
|
|
|
225 pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
|
|
|
226 implicit none
|
|
|
227 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
228 real(kind=10), intent(in) :: X
|
|
|
229 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
|
|
230 end function
|
|
|
231 #endif
|
|
|
232
|
|
|
233 #ifdef HAVE_GFC_REAL_16
|
|
|
234 pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
|
|
|
235 implicit none
|
|
|
236 type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
|
|
237 real(kind=16), intent(in) :: X
|
|
|
238 res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
|
|
239 end function
|
|
|
240 #endif
|
|
|
241
|
|
|
242 end module IEEE_EXCEPTIONS
|
