]>
Commit | Line | Data |
---|---|---|
8b198102 | 1 | ! Implementation of the IEEE_ARITHMETIC standard intrinsic module |
7adcbafe | 2 | ! Copyright (C) 2013-2022 Free Software Foundation, Inc. |
8b198102 FXC |
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_ARITHMETIC | |
32 | ||
33 | use IEEE_EXCEPTIONS | |
34 | implicit none | |
35 | private | |
36 | ||
37 | ! Every public symbol from IEEE_EXCEPTIONS must be made public here | |
38 | public :: IEEE_FLAG_TYPE, IEEE_INVALID, IEEE_OVERFLOW, & | |
39 | IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, & | |
40 | IEEE_ALL, IEEE_STATUS_TYPE, IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, & | |
41 | IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, & | |
de40fab2 FXC |
42 | IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING, & |
43 | IEEE_MODES_TYPE, IEEE_GET_MODES, IEEE_SET_MODES | |
8b198102 FXC |
44 | |
45 | ! Derived types and named constants | |
46 | ||
47 | type, public :: IEEE_CLASS_TYPE | |
48 | private | |
49 | integer :: hidden | |
50 | end type | |
51 | ||
52 | type(IEEE_CLASS_TYPE), parameter, public :: & | |
53 | IEEE_OTHER_VALUE = IEEE_CLASS_TYPE(0), & | |
54 | IEEE_SIGNALING_NAN = IEEE_CLASS_TYPE(1), & | |
55 | IEEE_QUIET_NAN = IEEE_CLASS_TYPE(2), & | |
56 | IEEE_NEGATIVE_INF = IEEE_CLASS_TYPE(3), & | |
57 | IEEE_NEGATIVE_NORMAL = IEEE_CLASS_TYPE(4), & | |
58 | IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(5), & | |
ede9dea5 | 59 | IEEE_NEGATIVE_SUBNORMAL= IEEE_CLASS_TYPE(5), & |
8b198102 FXC |
60 | IEEE_NEGATIVE_ZERO = IEEE_CLASS_TYPE(6), & |
61 | IEEE_POSITIVE_ZERO = IEEE_CLASS_TYPE(7), & | |
62 | IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), & | |
ede9dea5 | 63 | IEEE_POSITIVE_SUBNORMAL= IEEE_CLASS_TYPE(8), & |
8b198102 FXC |
64 | IEEE_POSITIVE_NORMAL = IEEE_CLASS_TYPE(9), & |
65 | IEEE_POSITIVE_INF = IEEE_CLASS_TYPE(10) | |
66 | ||
67 | type, public :: IEEE_ROUND_TYPE | |
68 | private | |
69 | integer :: hidden | |
70 | end type | |
71 | ||
72 | type(IEEE_ROUND_TYPE), parameter, public :: & | |
73 | IEEE_NEAREST = IEEE_ROUND_TYPE(GFC_FPE_TONEAREST), & | |
74 | IEEE_TO_ZERO = IEEE_ROUND_TYPE(GFC_FPE_TOWARDZERO), & | |
75 | IEEE_UP = IEEE_ROUND_TYPE(GFC_FPE_UPWARD), & | |
76 | IEEE_DOWN = IEEE_ROUND_TYPE(GFC_FPE_DOWNWARD), & | |
4637a1d2 | 77 | IEEE_AWAY = IEEE_ROUND_TYPE(GFC_FPE_AWAY), & |
8b198102 FXC |
78 | IEEE_OTHER = IEEE_ROUND_TYPE(0) |
79 | ||
80 | ||
81 | ! Equality operators on the derived types | |
0631e008 SK |
82 | ! Note, the FE overloads .eq. to == and .ne. to /= |
83 | interface operator (.eq.) | |
8b198102 FXC |
84 | module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ |
85 | end interface | |
0631e008 | 86 | public :: operator(.eq.) |
8b198102 | 87 | |
0631e008 | 88 | interface operator (.ne.) |
8b198102 FXC |
89 | module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE |
90 | end interface | |
0631e008 | 91 | public :: operator (.ne.) |
8b198102 FXC |
92 | |
93 | ||
94 | ! IEEE_IS_FINITE | |
95 | ||
96 | interface | |
97 | elemental logical function _gfortran_ieee_is_finite_4(X) | |
98 | real(kind=4), intent(in) :: X | |
99 | end function | |
100 | elemental logical function _gfortran_ieee_is_finite_8(X) | |
101 | real(kind=8), intent(in) :: X | |
102 | end function | |
22a49988 FXC |
103 | #ifdef HAVE_GFC_REAL_10 |
104 | elemental logical function _gfortran_ieee_is_finite_10(X) | |
105 | real(kind=10), intent(in) :: X | |
106 | end function | |
107 | #endif | |
108 | #ifdef HAVE_GFC_REAL_16 | |
109 | elemental logical function _gfortran_ieee_is_finite_16(X) | |
110 | real(kind=16), intent(in) :: X | |
111 | end function | |
112 | #endif | |
8b198102 FXC |
113 | end interface |
114 | ||
115 | interface IEEE_IS_FINITE | |
22a49988 FXC |
116 | procedure & |
117 | #ifdef HAVE_GFC_REAL_16 | |
118 | _gfortran_ieee_is_finite_16, & | |
119 | #endif | |
120 | #ifdef HAVE_GFC_REAL_10 | |
121 | _gfortran_ieee_is_finite_10, & | |
122 | #endif | |
123 | _gfortran_ieee_is_finite_8, _gfortran_ieee_is_finite_4 | |
8b198102 FXC |
124 | end interface |
125 | public :: IEEE_IS_FINITE | |
126 | ||
127 | ! IEEE_IS_NAN | |
128 | ||
129 | interface | |
130 | elemental logical function _gfortran_ieee_is_nan_4(X) | |
131 | real(kind=4), intent(in) :: X | |
132 | end function | |
133 | elemental logical function _gfortran_ieee_is_nan_8(X) | |
134 | real(kind=8), intent(in) :: X | |
135 | end function | |
22a49988 FXC |
136 | #ifdef HAVE_GFC_REAL_10 |
137 | elemental logical function _gfortran_ieee_is_nan_10(X) | |
138 | real(kind=10), intent(in) :: X | |
139 | end function | |
140 | #endif | |
141 | #ifdef HAVE_GFC_REAL_16 | |
142 | elemental logical function _gfortran_ieee_is_nan_16(X) | |
143 | real(kind=16), intent(in) :: X | |
144 | end function | |
145 | #endif | |
8b198102 FXC |
146 | end interface |
147 | ||
148 | interface IEEE_IS_NAN | |
22a49988 FXC |
149 | procedure & |
150 | #ifdef HAVE_GFC_REAL_16 | |
151 | _gfortran_ieee_is_nan_16, & | |
152 | #endif | |
153 | #ifdef HAVE_GFC_REAL_10 | |
154 | _gfortran_ieee_is_nan_10, & | |
155 | #endif | |
156 | _gfortran_ieee_is_nan_8, _gfortran_ieee_is_nan_4 | |
8b198102 FXC |
157 | end interface |
158 | public :: IEEE_IS_NAN | |
159 | ||
160 | ! IEEE_IS_NEGATIVE | |
161 | ||
162 | interface | |
163 | elemental logical function _gfortran_ieee_is_negative_4(X) | |
164 | real(kind=4), intent(in) :: X | |
165 | end function | |
166 | elemental logical function _gfortran_ieee_is_negative_8(X) | |
167 | real(kind=8), intent(in) :: X | |
168 | end function | |
22a49988 FXC |
169 | #ifdef HAVE_GFC_REAL_10 |
170 | elemental logical function _gfortran_ieee_is_negative_10(X) | |
171 | real(kind=10), intent(in) :: X | |
172 | end function | |
173 | #endif | |
174 | #ifdef HAVE_GFC_REAL_16 | |
175 | elemental logical function _gfortran_ieee_is_negative_16(X) | |
176 | real(kind=16), intent(in) :: X | |
177 | end function | |
178 | #endif | |
8b198102 FXC |
179 | end interface |
180 | ||
181 | interface IEEE_IS_NEGATIVE | |
22a49988 FXC |
182 | procedure & |
183 | #ifdef HAVE_GFC_REAL_16 | |
184 | _gfortran_ieee_is_negative_16, & | |
185 | #endif | |
186 | #ifdef HAVE_GFC_REAL_10 | |
187 | _gfortran_ieee_is_negative_10, & | |
188 | #endif | |
189 | _gfortran_ieee_is_negative_8, _gfortran_ieee_is_negative_4 | |
8b198102 FXC |
190 | end interface |
191 | public :: IEEE_IS_NEGATIVE | |
192 | ||
193 | ! IEEE_IS_NORMAL | |
194 | ||
195 | interface | |
196 | elemental logical function _gfortran_ieee_is_normal_4(X) | |
197 | real(kind=4), intent(in) :: X | |
198 | end function | |
199 | elemental logical function _gfortran_ieee_is_normal_8(X) | |
200 | real(kind=8), intent(in) :: X | |
201 | end function | |
22a49988 FXC |
202 | #ifdef HAVE_GFC_REAL_10 |
203 | elemental logical function _gfortran_ieee_is_normal_10(X) | |
204 | real(kind=10), intent(in) :: X | |
205 | end function | |
206 | #endif | |
207 | #ifdef HAVE_GFC_REAL_16 | |
208 | elemental logical function _gfortran_ieee_is_normal_16(X) | |
209 | real(kind=16), intent(in) :: X | |
210 | end function | |
211 | #endif | |
8b198102 FXC |
212 | end interface |
213 | ||
214 | interface IEEE_IS_NORMAL | |
22a49988 FXC |
215 | procedure & |
216 | #ifdef HAVE_GFC_REAL_16 | |
217 | _gfortran_ieee_is_normal_16, & | |
218 | #endif | |
219 | #ifdef HAVE_GFC_REAL_10 | |
220 | _gfortran_ieee_is_normal_10, & | |
221 | #endif | |
222 | _gfortran_ieee_is_normal_8, _gfortran_ieee_is_normal_4 | |
8b198102 FXC |
223 | end interface |
224 | public :: IEEE_IS_NORMAL | |
225 | ||
226 | ! IEEE_COPY_SIGN | |
227 | ||
22a49988 FXC |
228 | #define COPYSIGN_MACRO(A,B) \ |
229 | elemental real(kind = A) function \ | |
230 | _gfortran_ieee_copy_sign_/**/A/**/_/**/B (X,Y) ; \ | |
231 | real(kind = A), intent(in) :: X ; \ | |
232 | real(kind = B), intent(in) :: Y ; \ | |
233 | end function | |
234 | ||
8b198102 | 235 | interface |
22a49988 | 236 | #ifdef HAVE_GFC_REAL_16 |
11e07fa4 | 237 | COPYSIGN_MACRO(16,16) |
22a49988 | 238 | #ifdef HAVE_GFC_REAL_10 |
11e07fa4 SK |
239 | COPYSIGN_MACRO(16,10) |
240 | COPYSIGN_MACRO(10,16) | |
22a49988 | 241 | #endif |
11e07fa4 SK |
242 | COPYSIGN_MACRO(16,8) |
243 | COPYSIGN_MACRO(16,4) | |
22a49988 | 244 | COPYSIGN_MACRO(8,16) |
11e07fa4 | 245 | COPYSIGN_MACRO(4,16) |
22a49988 FXC |
246 | #endif |
247 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 248 | COPYSIGN_MACRO(10,10) |
11e07fa4 SK |
249 | COPYSIGN_MACRO(10,8) |
250 | COPYSIGN_MACRO(10,4) | |
251 | COPYSIGN_MACRO(8,10) | |
252 | COPYSIGN_MACRO(4,10) | |
22a49988 | 253 | #endif |
11e07fa4 SK |
254 | COPYSIGN_MACRO(8,8) |
255 | COPYSIGN_MACRO(8,4) | |
256 | COPYSIGN_MACRO(4,8) | |
257 | COPYSIGN_MACRO(4,4) | |
8b198102 FXC |
258 | end interface |
259 | ||
260 | interface IEEE_COPY_SIGN | |
22a49988 FXC |
261 | procedure & |
262 | #ifdef HAVE_GFC_REAL_16 | |
263 | _gfortran_ieee_copy_sign_16_16, & | |
264 | #ifdef HAVE_GFC_REAL_10 | |
265 | _gfortran_ieee_copy_sign_16_10, & | |
11e07fa4 | 266 | _gfortran_ieee_copy_sign_10_16, & |
22a49988 FXC |
267 | #endif |
268 | _gfortran_ieee_copy_sign_16_8, & | |
269 | _gfortran_ieee_copy_sign_16_4, & | |
11e07fa4 SK |
270 | _gfortran_ieee_copy_sign_8_16, & |
271 | _gfortran_ieee_copy_sign_4_16, & | |
22a49988 FXC |
272 | #endif |
273 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 FXC |
274 | _gfortran_ieee_copy_sign_10_10, & |
275 | _gfortran_ieee_copy_sign_10_8, & | |
276 | _gfortran_ieee_copy_sign_10_4, & | |
22a49988 | 277 | _gfortran_ieee_copy_sign_8_10, & |
11e07fa4 | 278 | _gfortran_ieee_copy_sign_4_10, & |
22a49988 FXC |
279 | #endif |
280 | _gfortran_ieee_copy_sign_8_8, & | |
281 | _gfortran_ieee_copy_sign_8_4, & | |
22a49988 FXC |
282 | _gfortran_ieee_copy_sign_4_8, & |
283 | _gfortran_ieee_copy_sign_4_4 | |
8b198102 FXC |
284 | end interface |
285 | public :: IEEE_COPY_SIGN | |
286 | ||
287 | ! IEEE_UNORDERED | |
288 | ||
22a49988 FXC |
289 | #define UNORDERED_MACRO(A,B) \ |
290 | elemental logical function \ | |
291 | _gfortran_ieee_unordered_/**/A/**/_/**/B (X,Y) ; \ | |
292 | real(kind = A), intent(in) :: X ; \ | |
293 | real(kind = B), intent(in) :: Y ; \ | |
294 | end function | |
295 | ||
8b198102 | 296 | interface |
22a49988 | 297 | #ifdef HAVE_GFC_REAL_16 |
11e07fa4 | 298 | UNORDERED_MACRO(16,16) |
22a49988 | 299 | #ifdef HAVE_GFC_REAL_10 |
11e07fa4 SK |
300 | UNORDERED_MACRO(16,10) |
301 | UNORDERED_MACRO(10,16) | |
22a49988 | 302 | #endif |
11e07fa4 SK |
303 | UNORDERED_MACRO(16,8) |
304 | UNORDERED_MACRO(16,4) | |
22a49988 | 305 | UNORDERED_MACRO(8,16) |
11e07fa4 | 306 | UNORDERED_MACRO(4,16) |
22a49988 FXC |
307 | #endif |
308 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 309 | UNORDERED_MACRO(10,10) |
11e07fa4 SK |
310 | UNORDERED_MACRO(10,8) |
311 | UNORDERED_MACRO(10,4) | |
312 | UNORDERED_MACRO(8,10) | |
313 | UNORDERED_MACRO(4,10) | |
22a49988 | 314 | #endif |
11e07fa4 SK |
315 | UNORDERED_MACRO(8,8) |
316 | UNORDERED_MACRO(8,4) | |
317 | UNORDERED_MACRO(4,8) | |
318 | UNORDERED_MACRO(4,4) | |
8b198102 FXC |
319 | end interface |
320 | ||
321 | interface IEEE_UNORDERED | |
22a49988 FXC |
322 | procedure & |
323 | #ifdef HAVE_GFC_REAL_16 | |
324 | _gfortran_ieee_unordered_16_16, & | |
325 | #ifdef HAVE_GFC_REAL_10 | |
326 | _gfortran_ieee_unordered_16_10, & | |
11e07fa4 | 327 | _gfortran_ieee_unordered_10_16, & |
22a49988 FXC |
328 | #endif |
329 | _gfortran_ieee_unordered_16_8, & | |
330 | _gfortran_ieee_unordered_16_4, & | |
11e07fa4 SK |
331 | _gfortran_ieee_unordered_8_16, & |
332 | _gfortran_ieee_unordered_4_16, & | |
22a49988 FXC |
333 | #endif |
334 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 FXC |
335 | _gfortran_ieee_unordered_10_10, & |
336 | _gfortran_ieee_unordered_10_8, & | |
337 | _gfortran_ieee_unordered_10_4, & | |
22a49988 | 338 | _gfortran_ieee_unordered_8_10, & |
11e07fa4 | 339 | _gfortran_ieee_unordered_4_10, & |
22a49988 FXC |
340 | #endif |
341 | _gfortran_ieee_unordered_8_8, & | |
342 | _gfortran_ieee_unordered_8_4, & | |
22a49988 FXC |
343 | _gfortran_ieee_unordered_4_8, & |
344 | _gfortran_ieee_unordered_4_4 | |
8b198102 FXC |
345 | end interface |
346 | public :: IEEE_UNORDERED | |
347 | ||
7c4c65d1 FXC |
348 | ! IEEE_FMA |
349 | ||
350 | interface | |
351 | elemental real(kind=4) function _gfortran_ieee_fma_4 (A, B, C) | |
352 | real(kind=4), intent(in) :: A, B, C | |
353 | end function | |
354 | elemental real(kind=8) function _gfortran_ieee_fma_8 (A, B, C) | |
355 | real(kind=8), intent(in) :: A, B, C | |
356 | end function | |
357 | #ifdef HAVE_GFC_REAL_10 | |
358 | elemental real(kind=10) function _gfortran_ieee_fma_10 (A, B, C) | |
359 | real(kind=10), intent(in) :: A, B, C | |
360 | end function | |
361 | #endif | |
362 | #ifdef HAVE_GFC_REAL_16 | |
363 | elemental real(kind=16) function _gfortran_ieee_fma_16 (A, B, C) | |
364 | real(kind=16), intent(in) :: A, B, C | |
365 | end function | |
366 | #endif | |
367 | end interface | |
368 | ||
369 | interface IEEE_FMA | |
370 | procedure & | |
371 | #ifdef HAVE_GFC_REAL_16 | |
372 | _gfortran_ieee_fma_16, & | |
373 | #endif | |
374 | #ifdef HAVE_GFC_REAL_10 | |
375 | _gfortran_ieee_fma_10, & | |
376 | #endif | |
377 | _gfortran_ieee_fma_8, _gfortran_ieee_fma_4 | |
378 | end interface | |
379 | public :: IEEE_FMA | |
380 | ||
8b198102 FXC |
381 | ! IEEE_LOGB |
382 | ||
383 | interface | |
384 | elemental real(kind=4) function _gfortran_ieee_logb_4 (X) | |
385 | real(kind=4), intent(in) :: X | |
386 | end function | |
387 | elemental real(kind=8) function _gfortran_ieee_logb_8 (X) | |
388 | real(kind=8), intent(in) :: X | |
389 | end function | |
22a49988 FXC |
390 | #ifdef HAVE_GFC_REAL_10 |
391 | elemental real(kind=10) function _gfortran_ieee_logb_10 (X) | |
392 | real(kind=10), intent(in) :: X | |
393 | end function | |
394 | #endif | |
395 | #ifdef HAVE_GFC_REAL_16 | |
396 | elemental real(kind=16) function _gfortran_ieee_logb_16 (X) | |
397 | real(kind=16), intent(in) :: X | |
398 | end function | |
399 | #endif | |
8b198102 FXC |
400 | end interface |
401 | ||
402 | interface IEEE_LOGB | |
22a49988 FXC |
403 | procedure & |
404 | #ifdef HAVE_GFC_REAL_16 | |
405 | _gfortran_ieee_logb_16, & | |
406 | #endif | |
407 | #ifdef HAVE_GFC_REAL_10 | |
408 | _gfortran_ieee_logb_10, & | |
409 | #endif | |
410 | _gfortran_ieee_logb_8, & | |
411 | _gfortran_ieee_logb_4 | |
8b198102 FXC |
412 | end interface |
413 | public :: IEEE_LOGB | |
414 | ||
415 | ! IEEE_NEXT_AFTER | |
416 | ||
22a49988 FXC |
417 | #define NEXT_AFTER_MACRO(A,B) \ |
418 | elemental real(kind = A) function \ | |
419 | _gfortran_ieee_next_after_/**/A/**/_/**/B (X,Y) ; \ | |
420 | real(kind = A), intent(in) :: X ; \ | |
421 | real(kind = B), intent(in) :: Y ; \ | |
422 | end function | |
423 | ||
8b198102 | 424 | interface |
22a49988 | 425 | #ifdef HAVE_GFC_REAL_16 |
11e07fa4 | 426 | NEXT_AFTER_MACRO(16,16) |
22a49988 | 427 | #ifdef HAVE_GFC_REAL_10 |
11e07fa4 SK |
428 | NEXT_AFTER_MACRO(16,10) |
429 | NEXT_AFTER_MACRO(10,16) | |
22a49988 | 430 | #endif |
11e07fa4 SK |
431 | NEXT_AFTER_MACRO(16,8) |
432 | NEXT_AFTER_MACRO(16,4) | |
22a49988 | 433 | NEXT_AFTER_MACRO(8,16) |
11e07fa4 | 434 | NEXT_AFTER_MACRO(4,16) |
22a49988 FXC |
435 | #endif |
436 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 437 | NEXT_AFTER_MACRO(10,10) |
11e07fa4 SK |
438 | NEXT_AFTER_MACRO(10,8) |
439 | NEXT_AFTER_MACRO(10,4) | |
440 | NEXT_AFTER_MACRO(8,10) | |
441 | NEXT_AFTER_MACRO(4,10) | |
22a49988 | 442 | #endif |
11e07fa4 SK |
443 | NEXT_AFTER_MACRO(8,8) |
444 | NEXT_AFTER_MACRO(8,4) | |
445 | NEXT_AFTER_MACRO(4,8) | |
446 | NEXT_AFTER_MACRO(4,4) | |
8b198102 FXC |
447 | end interface |
448 | ||
449 | interface IEEE_NEXT_AFTER | |
22a49988 FXC |
450 | procedure & |
451 | #ifdef HAVE_GFC_REAL_16 | |
452 | _gfortran_ieee_next_after_16_16, & | |
453 | #ifdef HAVE_GFC_REAL_10 | |
454 | _gfortran_ieee_next_after_16_10, & | |
11e07fa4 | 455 | _gfortran_ieee_next_after_10_16, & |
22a49988 FXC |
456 | #endif |
457 | _gfortran_ieee_next_after_16_8, & | |
458 | _gfortran_ieee_next_after_16_4, & | |
11e07fa4 SK |
459 | _gfortran_ieee_next_after_8_16, & |
460 | _gfortran_ieee_next_after_4_16, & | |
22a49988 FXC |
461 | #endif |
462 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 FXC |
463 | _gfortran_ieee_next_after_10_10, & |
464 | _gfortran_ieee_next_after_10_8, & | |
465 | _gfortran_ieee_next_after_10_4, & | |
22a49988 | 466 | _gfortran_ieee_next_after_8_10, & |
11e07fa4 | 467 | _gfortran_ieee_next_after_4_10, & |
22a49988 FXC |
468 | #endif |
469 | _gfortran_ieee_next_after_8_8, & | |
470 | _gfortran_ieee_next_after_8_4, & | |
22a49988 FXC |
471 | _gfortran_ieee_next_after_4_8, & |
472 | _gfortran_ieee_next_after_4_4 | |
8b198102 FXC |
473 | end interface |
474 | public :: IEEE_NEXT_AFTER | |
475 | ||
476 | ! IEEE_REM | |
477 | ||
22a49988 FXC |
478 | #define REM_MACRO(RES,A,B) \ |
479 | elemental real(kind = RES) function \ | |
480 | _gfortran_ieee_rem_/**/A/**/_/**/B (X,Y) ; \ | |
481 | real(kind = A), intent(in) :: X ; \ | |
482 | real(kind = B), intent(in) :: Y ; \ | |
483 | end function | |
484 | ||
8b198102 | 485 | interface |
22a49988 | 486 | #ifdef HAVE_GFC_REAL_16 |
11e07fa4 | 487 | REM_MACRO(16,16,16) |
22a49988 | 488 | #ifdef HAVE_GFC_REAL_10 |
11e07fa4 SK |
489 | REM_MACRO(16,16,10) |
490 | REM_MACRO(16,10,16) | |
22a49988 | 491 | #endif |
11e07fa4 SK |
492 | REM_MACRO(16,16,8) |
493 | REM_MACRO(16,16,4) | |
22a49988 | 494 | REM_MACRO(16,8,16) |
11e07fa4 | 495 | REM_MACRO(16,4,16) |
22a49988 FXC |
496 | #endif |
497 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 498 | REM_MACRO(10,10,10) |
11e07fa4 SK |
499 | REM_MACRO(10,10,8) |
500 | REM_MACRO(10,10,4) | |
501 | REM_MACRO(10,8,10) | |
502 | REM_MACRO(10,4,10) | |
22a49988 | 503 | #endif |
11e07fa4 SK |
504 | REM_MACRO(8,8,8) |
505 | REM_MACRO(8,8,4) | |
506 | REM_MACRO(8,4,8) | |
507 | REM_MACRO(4,4,4) | |
8b198102 FXC |
508 | end interface |
509 | ||
510 | interface IEEE_REM | |
22a49988 FXC |
511 | procedure & |
512 | #ifdef HAVE_GFC_REAL_16 | |
513 | _gfortran_ieee_rem_16_16, & | |
514 | #ifdef HAVE_GFC_REAL_10 | |
515 | _gfortran_ieee_rem_16_10, & | |
11e07fa4 | 516 | _gfortran_ieee_rem_10_16, & |
22a49988 FXC |
517 | #endif |
518 | _gfortran_ieee_rem_16_8, & | |
519 | _gfortran_ieee_rem_16_4, & | |
11e07fa4 SK |
520 | _gfortran_ieee_rem_8_16, & |
521 | _gfortran_ieee_rem_4_16, & | |
22a49988 FXC |
522 | #endif |
523 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 FXC |
524 | _gfortran_ieee_rem_10_10, & |
525 | _gfortran_ieee_rem_10_8, & | |
526 | _gfortran_ieee_rem_10_4, & | |
22a49988 | 527 | _gfortran_ieee_rem_8_10, & |
11e07fa4 | 528 | _gfortran_ieee_rem_4_10, & |
22a49988 FXC |
529 | #endif |
530 | _gfortran_ieee_rem_8_8, & | |
531 | _gfortran_ieee_rem_8_4, & | |
22a49988 FXC |
532 | _gfortran_ieee_rem_4_8, & |
533 | _gfortran_ieee_rem_4_4 | |
8b198102 FXC |
534 | end interface |
535 | public :: IEEE_REM | |
536 | ||
537 | ! IEEE_RINT | |
538 | ||
539 | interface | |
540 | elemental real(kind=4) function _gfortran_ieee_rint_4 (X) | |
541 | real(kind=4), intent(in) :: X | |
542 | end function | |
543 | elemental real(kind=8) function _gfortran_ieee_rint_8 (X) | |
544 | real(kind=8), intent(in) :: X | |
545 | end function | |
22a49988 FXC |
546 | #ifdef HAVE_GFC_REAL_10 |
547 | elemental real(kind=10) function _gfortran_ieee_rint_10 (X) | |
548 | real(kind=10), intent(in) :: X | |
549 | end function | |
550 | #endif | |
551 | #ifdef HAVE_GFC_REAL_16 | |
552 | elemental real(kind=16) function _gfortran_ieee_rint_16 (X) | |
553 | real(kind=16), intent(in) :: X | |
554 | end function | |
555 | #endif | |
8b198102 FXC |
556 | end interface |
557 | ||
558 | interface IEEE_RINT | |
22a49988 FXC |
559 | procedure & |
560 | #ifdef HAVE_GFC_REAL_16 | |
561 | _gfortran_ieee_rint_16, & | |
562 | #endif | |
563 | #ifdef HAVE_GFC_REAL_10 | |
564 | _gfortran_ieee_rint_10, & | |
565 | #endif | |
566 | _gfortran_ieee_rint_8, _gfortran_ieee_rint_4 | |
8b198102 FXC |
567 | end interface |
568 | public :: IEEE_RINT | |
569 | ||
570 | ! IEEE_SCALB | |
571 | ||
572 | interface | |
8ab8b08a SK |
573 | #ifdef HAVE_GFC_INTEGER_16 |
574 | #ifdef HAVE_GFC_REAL_16 | |
575 | elemental real(kind=16) function _gfortran_ieee_scalb_16_16 (X, I) | |
576 | real(kind=16), intent(in) :: X | |
577 | integer(kind=16), intent(in) :: I | |
578 | end function | |
579 | #endif | |
580 | #ifdef HAVE_GFC_REAL_10 | |
581 | elemental real(kind=10) function _gfortran_ieee_scalb_10_16 (X, I) | |
582 | real(kind=10), intent(in) :: X | |
583 | integer(kind=16), intent(in) :: I | |
584 | end function | |
585 | #endif | |
586 | elemental real(kind=8) function _gfortran_ieee_scalb_8_16 (X, I) | |
587 | real(kind=8), intent(in) :: X | |
588 | integer(kind=16), intent(in) :: I | |
589 | end function | |
590 | elemental real(kind=4) function _gfortran_ieee_scalb_4_16 (X, I) | |
8b198102 | 591 | real(kind=4), intent(in) :: X |
8ab8b08a | 592 | integer(kind=16), intent(in) :: I |
8b198102 | 593 | end function |
8ab8b08a SK |
594 | #endif |
595 | ||
596 | #ifdef HAVE_GFC_INTEGER_8 | |
597 | #ifdef HAVE_GFC_REAL_16 | |
598 | elemental real(kind=16) function _gfortran_ieee_scalb_16_8 (X, I) | |
599 | real(kind=16), intent(in) :: X | |
600 | integer(kind=8), intent(in) :: I | |
601 | end function | |
602 | #endif | |
603 | #ifdef HAVE_GFC_REAL_10 | |
604 | elemental real(kind=10) function _gfortran_ieee_scalb_10_8 (X, I) | |
605 | real(kind=10), intent(in) :: X | |
606 | integer(kind=8), intent(in) :: I | |
607 | end function | |
608 | #endif | |
609 | elemental real(kind=8) function _gfortran_ieee_scalb_8_8 (X, I) | |
8b198102 | 610 | real(kind=8), intent(in) :: X |
8ab8b08a SK |
611 | integer(kind=8), intent(in) :: I |
612 | end function | |
613 | elemental real(kind=4) function _gfortran_ieee_scalb_4_8 (X, I) | |
614 | real(kind=4), intent(in) :: X | |
615 | integer(kind=8), intent(in) :: I | |
616 | end function | |
617 | #endif | |
618 | ||
619 | #ifdef HAVE_GFC_INTEGER_2 | |
620 | #ifdef HAVE_GFC_REAL_16 | |
621 | elemental real(kind=16) function _gfortran_ieee_scalb_16_2 (X, I) | |
622 | real(kind=16), intent(in) :: X | |
623 | integer(kind=2), intent(in) :: I | |
8b198102 | 624 | end function |
8ab8b08a | 625 | #endif |
22a49988 | 626 | #ifdef HAVE_GFC_REAL_10 |
8ab8b08a | 627 | elemental real(kind=10) function _gfortran_ieee_scalb_10_2 (X, I) |
22a49988 | 628 | real(kind=10), intent(in) :: X |
8ab8b08a SK |
629 | integer(kind=2), intent(in) :: I |
630 | end function | |
631 | #endif | |
632 | elemental real(kind=8) function _gfortran_ieee_scalb_8_2 (X, I) | |
633 | real(kind=8), intent(in) :: X | |
634 | integer(kind=2), intent(in) :: I | |
635 | end function | |
636 | elemental real(kind=4) function _gfortran_ieee_scalb_4_2 (X, I) | |
637 | real(kind=4), intent(in) :: X | |
638 | integer(kind=2), intent(in) :: I | |
639 | end function | |
640 | #endif | |
641 | ||
642 | #ifdef HAVE_GFC_INTEGER_1 | |
643 | #ifdef HAVE_GFC_REAL_16 | |
644 | elemental real(kind=16) function _gfortran_ieee_scalb_16_1 (X, I) | |
645 | real(kind=16), intent(in) :: X | |
646 | integer(kind=1), intent(in) :: I | |
22a49988 FXC |
647 | end function |
648 | #endif | |
8ab8b08a SK |
649 | #ifdef HAVE_GFC_REAL_10 |
650 | elemental real(kind=10) function _gfortran_ieee_scalb_10_1 (X, I) | |
651 | real(kind=10), intent(in) :: X | |
652 | integer(kind=1), intent(in) :: I | |
653 | end function | |
654 | #endif | |
655 | elemental real(kind=8) function _gfortran_ieee_scalb_8_1 (X, I) | |
656 | real(kind=8), intent(in) :: X | |
657 | integer(kind=1), intent(in) :: I | |
658 | end function | |
659 | elemental real(kind=4) function _gfortran_ieee_scalb_4_1 (X, I) | |
660 | real(kind=4), intent(in) :: X | |
661 | integer(kind=1), intent(in) :: I | |
662 | end function | |
663 | #endif | |
664 | ||
22a49988 | 665 | #ifdef HAVE_GFC_REAL_16 |
8ab8b08a | 666 | elemental real(kind=16) function _gfortran_ieee_scalb_16_4 (X, I) |
22a49988 FXC |
667 | real(kind=16), intent(in) :: X |
668 | integer, intent(in) :: I | |
669 | end function | |
670 | #endif | |
8ab8b08a SK |
671 | #ifdef HAVE_GFC_REAL_10 |
672 | elemental real(kind=10) function _gfortran_ieee_scalb_10_4 (X, I) | |
673 | real(kind=10), intent(in) :: X | |
674 | integer, intent(in) :: I | |
675 | end function | |
676 | #endif | |
677 | elemental real(kind=8) function _gfortran_ieee_scalb_8_4 (X, I) | |
678 | real(kind=8), intent(in) :: X | |
679 | integer, intent(in) :: I | |
680 | end function | |
681 | elemental real(kind=4) function _gfortran_ieee_scalb_4_4 (X, I) | |
682 | real(kind=4), intent(in) :: X | |
683 | integer, intent(in) :: I | |
684 | end function | |
8b198102 FXC |
685 | end interface |
686 | ||
687 | interface IEEE_SCALB | |
22a49988 | 688 | procedure & |
8ab8b08a SK |
689 | #ifdef HAVE_GFC_INTEGER_16 |
690 | #ifdef HAVE_GFC_REAL_16 | |
691 | _gfortran_ieee_scalb_16_16, & | |
692 | #endif | |
693 | #ifdef HAVE_GFC_REAL_10 | |
694 | _gfortran_ieee_scalb_10_16, & | |
695 | #endif | |
696 | _gfortran_ieee_scalb_8_16, & | |
697 | _gfortran_ieee_scalb_4_16, & | |
698 | #endif | |
699 | #ifdef HAVE_GFC_INTEGER_8 | |
700 | #ifdef HAVE_GFC_REAL_16 | |
701 | _gfortran_ieee_scalb_16_8, & | |
702 | #endif | |
703 | #ifdef HAVE_GFC_REAL_10 | |
704 | _gfortran_ieee_scalb_10_8, & | |
705 | #endif | |
706 | _gfortran_ieee_scalb_8_8, & | |
707 | _gfortran_ieee_scalb_4_8, & | |
708 | #endif | |
709 | #ifdef HAVE_GFC_INTEGER_2 | |
710 | #ifdef HAVE_GFC_REAL_16 | |
711 | _gfortran_ieee_scalb_16_2, & | |
712 | #endif | |
713 | #ifdef HAVE_GFC_REAL_10 | |
714 | _gfortran_ieee_scalb_10_2, & | |
715 | #endif | |
716 | _gfortran_ieee_scalb_8_2, & | |
717 | _gfortran_ieee_scalb_4_2, & | |
718 | #endif | |
719 | #ifdef HAVE_GFC_INTEGER_1 | |
720 | #ifdef HAVE_GFC_REAL_16 | |
721 | _gfortran_ieee_scalb_16_1, & | |
722 | #endif | |
723 | #ifdef HAVE_GFC_REAL_10 | |
724 | _gfortran_ieee_scalb_10_1, & | |
725 | #endif | |
726 | _gfortran_ieee_scalb_8_1, & | |
727 | _gfortran_ieee_scalb_4_1, & | |
728 | #endif | |
22a49988 | 729 | #ifdef HAVE_GFC_REAL_16 |
8ab8b08a | 730 | _gfortran_ieee_scalb_16_4, & |
22a49988 FXC |
731 | #endif |
732 | #ifdef HAVE_GFC_REAL_10 | |
8ab8b08a | 733 | _gfortran_ieee_scalb_10_4, & |
22a49988 | 734 | #endif |
8ab8b08a SK |
735 | _gfortran_ieee_scalb_8_4, & |
736 | _gfortran_ieee_scalb_4_4 | |
8b198102 FXC |
737 | end interface |
738 | public :: IEEE_SCALB | |
739 | ||
7c4c65d1 FXC |
740 | ! IEEE_SIGNBIT |
741 | ||
742 | interface | |
743 | elemental logical function _gfortran_ieee_signbit_4 (X) | |
744 | real(kind=4), intent(in) :: X | |
745 | end function | |
746 | elemental logical function _gfortran_ieee_signbit_8 (X) | |
747 | real(kind=8), intent(in) :: X | |
748 | end function | |
749 | #ifdef HAVE_GFC_REAL_10 | |
750 | elemental logical function _gfortran_ieee_signbit_10 (X) | |
751 | real(kind=10), intent(in) :: X | |
752 | end function | |
753 | #endif | |
754 | #ifdef HAVE_GFC_REAL_16 | |
755 | elemental logical function _gfortran_ieee_signbit_16 (X) | |
756 | real(kind=16), intent(in) :: X | |
757 | end function | |
758 | #endif | |
759 | end interface | |
760 | ||
761 | interface IEEE_SIGNBIT | |
762 | procedure & | |
763 | #ifdef HAVE_GFC_REAL_16 | |
764 | _gfortran_ieee_signbit_16, & | |
765 | #endif | |
766 | #ifdef HAVE_GFC_REAL_10 | |
767 | _gfortran_ieee_signbit_10, & | |
768 | #endif | |
769 | _gfortran_ieee_signbit_8, _gfortran_ieee_signbit_4 | |
770 | end interface | |
771 | public :: IEEE_SIGNBIT | |
772 | ||
8b198102 FXC |
773 | ! IEEE_VALUE |
774 | ||
775 | interface IEEE_VALUE | |
22a49988 FXC |
776 | module procedure & |
777 | #ifdef HAVE_GFC_REAL_16 | |
778 | IEEE_VALUE_16, & | |
779 | #endif | |
780 | #ifdef HAVE_GFC_REAL_10 | |
781 | IEEE_VALUE_10, & | |
782 | #endif | |
783 | IEEE_VALUE_8, IEEE_VALUE_4 | |
8b198102 FXC |
784 | end interface |
785 | public :: IEEE_VALUE | |
786 | ||
787 | ! IEEE_CLASS | |
788 | ||
789 | interface IEEE_CLASS | |
22a49988 FXC |
790 | module procedure & |
791 | #ifdef HAVE_GFC_REAL_16 | |
792 | IEEE_CLASS_16, & | |
793 | #endif | |
794 | #ifdef HAVE_GFC_REAL_10 | |
795 | IEEE_CLASS_10, & | |
796 | #endif | |
797 | IEEE_CLASS_8, IEEE_CLASS_4 | |
8b198102 FXC |
798 | end interface |
799 | public :: IEEE_CLASS | |
800 | ||
801 | ! Public declarations for contained procedures | |
802 | public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE | |
803 | public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE | |
804 | public :: IEEE_SELECTED_REAL_KIND | |
805 | ||
806 | ! IEEE_SUPPORT_ROUNDING | |
807 | ||
808 | interface IEEE_SUPPORT_ROUNDING | |
809 | module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, & | |
810 | #ifdef HAVE_GFC_REAL_10 | |
811 | IEEE_SUPPORT_ROUNDING_10, & | |
812 | #endif | |
813 | #ifdef HAVE_GFC_REAL_16 | |
814 | IEEE_SUPPORT_ROUNDING_16, & | |
815 | #endif | |
816 | IEEE_SUPPORT_ROUNDING_NOARG | |
817 | end interface | |
818 | public :: IEEE_SUPPORT_ROUNDING | |
519196a2 | 819 | |
8b198102 FXC |
820 | ! Interface to the FPU-specific function |
821 | interface | |
822 | pure integer function support_rounding_helper(flag) & | |
823 | bind(c, name="_gfortrani_support_fpu_rounding_mode") | |
824 | integer, intent(in), value :: flag | |
825 | end function | |
826 | end interface | |
827 | ||
f5168e47 FXC |
828 | ! IEEE_SUPPORT_UNDERFLOW_CONTROL |
829 | ||
830 | interface IEEE_SUPPORT_UNDERFLOW_CONTROL | |
831 | module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, & | |
832 | IEEE_SUPPORT_UNDERFLOW_CONTROL_8, & | |
833 | #ifdef HAVE_GFC_REAL_10 | |
834 | IEEE_SUPPORT_UNDERFLOW_CONTROL_10, & | |
835 | #endif | |
836 | #ifdef HAVE_GFC_REAL_16 | |
837 | IEEE_SUPPORT_UNDERFLOW_CONTROL_16, & | |
838 | #endif | |
839 | IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG | |
840 | end interface | |
841 | public :: IEEE_SUPPORT_UNDERFLOW_CONTROL | |
519196a2 | 842 | |
f5168e47 FXC |
843 | ! Interface to the FPU-specific function |
844 | interface | |
845 | pure integer function support_underflow_control_helper(kind) & | |
846 | bind(c, name="_gfortrani_support_fpu_underflow_control") | |
847 | integer, intent(in), value :: kind | |
848 | end function | |
849 | end interface | |
850 | ||
8b198102 FXC |
851 | ! IEEE_SUPPORT_* generic functions |
852 | ||
853 | #if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16) | |
854 | # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG | |
855 | #elif defined(HAVE_GFC_REAL_10) | |
856 | # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG | |
857 | #elif defined(HAVE_GFC_REAL_16) | |
858 | # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG | |
859 | #else | |
860 | # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG | |
861 | #endif | |
862 | ||
863 | #define SUPPORTGENERIC(NAME) \ | |
864 | interface NAME ; module procedure MACRO1(NAME) ; end interface ; \ | |
865 | public :: NAME | |
866 | ||
867 | SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE) | |
868 | SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL) | |
ede9dea5 | 869 | SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL) |
8b198102 FXC |
870 | SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE) |
871 | SUPPORTGENERIC(IEEE_SUPPORT_INF) | |
872 | SUPPORTGENERIC(IEEE_SUPPORT_IO) | |
873 | SUPPORTGENERIC(IEEE_SUPPORT_NAN) | |
874 | SUPPORTGENERIC(IEEE_SUPPORT_SQRT) | |
875 | SUPPORTGENERIC(IEEE_SUPPORT_STANDARD) | |
8b198102 FXC |
876 | |
877 | contains | |
878 | ||
879 | ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE | |
880 | elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res) | |
881 | implicit none | |
882 | type(IEEE_CLASS_TYPE), intent(in) :: X, Y | |
883 | res = (X%hidden == Y%hidden) | |
884 | end function | |
885 | ||
886 | elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res) | |
887 | implicit none | |
888 | type(IEEE_CLASS_TYPE), intent(in) :: X, Y | |
889 | res = (X%hidden /= Y%hidden) | |
890 | end function | |
891 | ||
892 | elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res) | |
893 | implicit none | |
894 | type(IEEE_ROUND_TYPE), intent(in) :: X, Y | |
895 | res = (X%hidden == Y%hidden) | |
896 | end function | |
897 | ||
898 | elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res) | |
899 | implicit none | |
900 | type(IEEE_ROUND_TYPE), intent(in) :: X, Y | |
901 | res = (X%hidden /= Y%hidden) | |
902 | end function | |
903 | ||
22a49988 | 904 | |
8b198102 | 905 | ! IEEE_SELECTED_REAL_KIND |
22a49988 | 906 | |
8b198102 FXC |
907 | integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res) |
908 | implicit none | |
909 | integer, intent(in), optional :: P, R, RADIX | |
22a49988 FXC |
910 | |
911 | ! Currently, if IEEE is supported and this module is built, it means | |
912 | ! all our floating-point types conform to IEEE. Hence, we simply call | |
913 | ! SELECTED_REAL_KIND. | |
914 | ||
915 | res = SELECTED_REAL_KIND (P, R, RADIX) | |
916 | ||
8b198102 FXC |
917 | end function |
918 | ||
919 | ||
920 | ! IEEE_CLASS | |
921 | ||
922 | elemental function IEEE_CLASS_4 (X) result(res) | |
923 | implicit none | |
924 | real(kind=4), intent(in) :: X | |
925 | type(IEEE_CLASS_TYPE) :: res | |
926 | ||
927 | interface | |
928 | pure integer function _gfortrani_ieee_class_helper_4(val) | |
929 | real(kind=4), intent(in) :: val | |
930 | end function | |
931 | end interface | |
932 | ||
933 | res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X)) | |
934 | end function | |
935 | ||
936 | elemental function IEEE_CLASS_8 (X) result(res) | |
937 | implicit none | |
938 | real(kind=8), intent(in) :: X | |
939 | type(IEEE_CLASS_TYPE) :: res | |
940 | ||
941 | interface | |
942 | pure integer function _gfortrani_ieee_class_helper_8(val) | |
943 | real(kind=8), intent(in) :: val | |
944 | end function | |
945 | end interface | |
946 | ||
947 | res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X)) | |
948 | end function | |
949 | ||
22a49988 FXC |
950 | #ifdef HAVE_GFC_REAL_10 |
951 | elemental function IEEE_CLASS_10 (X) result(res) | |
952 | implicit none | |
953 | real(kind=10), intent(in) :: X | |
954 | type(IEEE_CLASS_TYPE) :: res | |
955 | ||
956 | interface | |
957 | pure integer function _gfortrani_ieee_class_helper_10(val) | |
958 | real(kind=10), intent(in) :: val | |
959 | end function | |
960 | end interface | |
961 | ||
962 | res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_10(X)) | |
963 | end function | |
964 | #endif | |
965 | ||
966 | #ifdef HAVE_GFC_REAL_16 | |
967 | elemental function IEEE_CLASS_16 (X) result(res) | |
968 | implicit none | |
969 | real(kind=16), intent(in) :: X | |
970 | type(IEEE_CLASS_TYPE) :: res | |
971 | ||
972 | interface | |
973 | pure integer function _gfortrani_ieee_class_helper_16(val) | |
974 | real(kind=16), intent(in) :: val | |
975 | end function | |
976 | end interface | |
977 | ||
978 | res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_16(X)) | |
979 | end function | |
980 | #endif | |
981 | ||
982 | ||
8b198102 FXC |
983 | ! IEEE_VALUE |
984 | ||
8a92685e | 985 | elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res) |
8b198102 | 986 | real(kind=4), intent(in) :: X |
8a92685e | 987 | type(IEEE_CLASS_TYPE), intent(in) :: CLASS |
90045c5d FXC |
988 | |
989 | interface | |
990 | pure real(kind=4) function _gfortrani_ieee_value_helper_4(x) | |
991 | use ISO_C_BINDING, only: C_INT | |
992 | integer(kind=C_INT), value :: x | |
993 | end function | |
994 | end interface | |
995 | ||
996 | res = _gfortrani_ieee_value_helper_4(CLASS%hidden) | |
8b198102 FXC |
997 | end function |
998 | ||
8a92685e | 999 | elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res) |
8b198102 | 1000 | real(kind=8), intent(in) :: X |
8a92685e | 1001 | type(IEEE_CLASS_TYPE), intent(in) :: CLASS |
90045c5d FXC |
1002 | |
1003 | interface | |
1004 | pure real(kind=8) function _gfortrani_ieee_value_helper_8(x) | |
1005 | use ISO_C_BINDING, only: C_INT | |
1006 | integer(kind=C_INT), value :: x | |
1007 | end function | |
1008 | end interface | |
1009 | ||
1010 | res = _gfortrani_ieee_value_helper_8(CLASS%hidden) | |
8b198102 FXC |
1011 | end function |
1012 | ||
22a49988 | 1013 | #ifdef HAVE_GFC_REAL_10 |
8a92685e | 1014 | elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res) |
22a49988 | 1015 | real(kind=10), intent(in) :: X |
8a92685e | 1016 | type(IEEE_CLASS_TYPE), intent(in) :: CLASS |
90045c5d FXC |
1017 | |
1018 | interface | |
1019 | pure real(kind=10) function _gfortrani_ieee_value_helper_10(x) | |
1020 | use ISO_C_BINDING, only: C_INT | |
1021 | integer(kind=C_INT), value :: x | |
1022 | end function | |
1023 | end interface | |
1024 | ||
1025 | res = _gfortrani_ieee_value_helper_10(CLASS%hidden) | |
22a49988 | 1026 | end function |
8a92685e | 1027 | |
22a49988 FXC |
1028 | #endif |
1029 | ||
1030 | #ifdef HAVE_GFC_REAL_16 | |
8a92685e | 1031 | elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res) |
22a49988 | 1032 | real(kind=16), intent(in) :: X |
8a92685e | 1033 | type(IEEE_CLASS_TYPE), intent(in) :: CLASS |
90045c5d FXC |
1034 | |
1035 | interface | |
1036 | pure real(kind=16) function _gfortrani_ieee_value_helper_16(x) | |
1037 | use ISO_C_BINDING, only: C_INT | |
1038 | integer(kind=C_INT), value :: x | |
1039 | end function | |
1040 | end interface | |
1041 | ||
1042 | res = _gfortrani_ieee_value_helper_16(CLASS%hidden) | |
22a49988 FXC |
1043 | end function |
1044 | #endif | |
1045 | ||
8b198102 FXC |
1046 | |
1047 | ! IEEE_GET_ROUNDING_MODE | |
1048 | ||
4637a1d2 | 1049 | subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE, RADIX) |
8b198102 FXC |
1050 | implicit none |
1051 | type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE | |
4637a1d2 | 1052 | integer, intent(in), optional :: RADIX |
8b198102 FXC |
1053 | |
1054 | interface | |
1055 | integer function helper() & | |
1056 | bind(c, name="_gfortrani_get_fpu_rounding_mode") | |
1057 | end function | |
1058 | end interface | |
1059 | ||
f5168e47 | 1060 | ROUND_VALUE = IEEE_ROUND_TYPE(helper()) |
8b198102 FXC |
1061 | end subroutine |
1062 | ||
1063 | ||
1064 | ! IEEE_SET_ROUNDING_MODE | |
1065 | ||
4637a1d2 | 1066 | subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE, RADIX) |
8b198102 FXC |
1067 | implicit none |
1068 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
4637a1d2 | 1069 | integer, intent(in), optional :: RADIX |
8b198102 FXC |
1070 | |
1071 | interface | |
1072 | subroutine helper(val) & | |
1073 | bind(c, name="_gfortrani_set_fpu_rounding_mode") | |
1074 | integer, value :: val | |
1075 | end subroutine | |
1076 | end interface | |
519196a2 FXC |
1077 | |
1078 | ! We do not support RADIX = 10, and such calls should not | |
1079 | ! modify the binary rounding mode. | |
1080 | if (present(RADIX)) then | |
1081 | if (RADIX == 10) return | |
1082 | end if | |
1083 | ||
8b198102 FXC |
1084 | call helper(ROUND_VALUE%hidden) |
1085 | end subroutine | |
1086 | ||
1087 | ||
1088 | ! IEEE_GET_UNDERFLOW_MODE | |
1089 | ||
1090 | subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL) | |
1091 | implicit none | |
1092 | logical, intent(out) :: GRADUAL | |
f5168e47 FXC |
1093 | |
1094 | interface | |
1095 | integer function helper() & | |
1096 | bind(c, name="_gfortrani_get_fpu_underflow_mode") | |
1097 | end function | |
1098 | end interface | |
1099 | ||
1100 | GRADUAL = (helper() /= 0) | |
8b198102 FXC |
1101 | end subroutine |
1102 | ||
1103 | ||
1104 | ! IEEE_SET_UNDERFLOW_MODE | |
1105 | ||
1106 | subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL) | |
1107 | implicit none | |
1108 | logical, intent(in) :: GRADUAL | |
f5168e47 FXC |
1109 | |
1110 | interface | |
1111 | subroutine helper(val) & | |
1112 | bind(c, name="_gfortrani_set_fpu_underflow_mode") | |
1113 | integer, value :: val | |
1114 | end subroutine | |
1115 | end interface | |
1116 | ||
1117 | call helper(merge(1, 0, GRADUAL)) | |
8b198102 FXC |
1118 | end subroutine |
1119 | ||
1120 | ! IEEE_SUPPORT_ROUNDING | |
1121 | ||
1122 | pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res) | |
1123 | implicit none | |
1124 | real(kind=4), intent(in) :: X | |
1125 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
1126 | res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) | |
1127 | end function | |
1128 | ||
1129 | pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res) | |
1130 | implicit none | |
1131 | real(kind=8), intent(in) :: X | |
1132 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
1133 | res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) | |
1134 | end function | |
1135 | ||
1136 | #ifdef HAVE_GFC_REAL_10 | |
1137 | pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res) | |
1138 | implicit none | |
1139 | real(kind=10), intent(in) :: X | |
1140 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
22a49988 | 1141 | res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) |
8b198102 FXC |
1142 | end function |
1143 | #endif | |
1144 | ||
1145 | #ifdef HAVE_GFC_REAL_16 | |
1146 | pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res) | |
1147 | implicit none | |
1148 | real(kind=16), intent(in) :: X | |
1149 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
22a49988 | 1150 | res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) |
8b198102 FXC |
1151 | end function |
1152 | #endif | |
1153 | ||
1154 | pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res) | |
1155 | implicit none | |
1156 | type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE | |
8b198102 | 1157 | res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) |
8b198102 FXC |
1158 | end function |
1159 | ||
f5168e47 FXC |
1160 | ! IEEE_SUPPORT_UNDERFLOW_CONTROL |
1161 | ||
1162 | pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res) | |
1163 | implicit none | |
1164 | real(kind=4), intent(in) :: X | |
1165 | res = (support_underflow_control_helper(4) /= 0) | |
1166 | end function | |
1167 | ||
1168 | pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res) | |
1169 | implicit none | |
1170 | real(kind=8), intent(in) :: X | |
1171 | res = (support_underflow_control_helper(8) /= 0) | |
1172 | end function | |
1173 | ||
1174 | #ifdef HAVE_GFC_REAL_10 | |
1175 | pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res) | |
1176 | implicit none | |
1177 | real(kind=10), intent(in) :: X | |
22a49988 | 1178 | res = (support_underflow_control_helper(10) /= 0) |
f5168e47 FXC |
1179 | end function |
1180 | #endif | |
1181 | ||
1182 | #ifdef HAVE_GFC_REAL_16 | |
1183 | pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res) | |
1184 | implicit none | |
1185 | real(kind=16), intent(in) :: X | |
22a49988 | 1186 | res = (support_underflow_control_helper(16) /= 0) |
f5168e47 FXC |
1187 | end function |
1188 | #endif | |
1189 | ||
1190 | pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res) | |
1191 | implicit none | |
f5168e47 | 1192 | res = (support_underflow_control_helper(4) /= 0 & |
22a49988 FXC |
1193 | .and. support_underflow_control_helper(8) /= 0 & |
1194 | #ifdef HAVE_GFC_REAL_10 | |
1195 | .and. support_underflow_control_helper(10) /= 0 & | |
1196 | #endif | |
1197 | #ifdef HAVE_GFC_REAL_16 | |
1198 | .and. support_underflow_control_helper(16) /= 0 & | |
f5168e47 | 1199 | #endif |
22a49988 | 1200 | ) |
f5168e47 FXC |
1201 | end function |
1202 | ||
8b198102 FXC |
1203 | ! IEEE_SUPPORT_* functions |
1204 | ||
1205 | #define SUPPORTMACRO(NAME, INTKIND, VALUE) \ | |
1206 | pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \ | |
1207 | implicit none ; \ | |
1208 | real(INTKIND), intent(in) :: X(..) ; \ | |
1209 | res = VALUE ; \ | |
1210 | end function | |
1211 | ||
1212 | #define SUPPORTMACRO_NOARG(NAME, VALUE) \ | |
1213 | pure logical function NAME/**/_NOARG () result(res) ; \ | |
1214 | implicit none ; \ | |
1215 | res = VALUE ; \ | |
1216 | end function | |
1217 | ||
1218 | ! IEEE_SUPPORT_DATATYPE | |
1219 | ||
1220 | SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.) | |
1221 | SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.) | |
1222 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1223 | SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.) |
8b198102 FXC |
1224 | #endif |
1225 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1226 | SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.) |
8b198102 | 1227 | #endif |
8b198102 | 1228 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.) |
8b198102 | 1229 | |
ede9dea5 | 1230 | ! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL |
8b198102 FXC |
1231 | |
1232 | SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.) | |
1233 | SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.) | |
1234 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1235 | SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.) |
8b198102 FXC |
1236 | #endif |
1237 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1238 | SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.) |
8b198102 | 1239 | #endif |
8b198102 | 1240 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.) |
8b198102 | 1241 | |
ede9dea5 SK |
1242 | SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.) |
1243 | SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.) | |
1244 | #ifdef HAVE_GFC_REAL_10 | |
1245 | SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.) | |
1246 | #endif | |
1247 | #ifdef HAVE_GFC_REAL_16 | |
1248 | SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.) | |
1249 | #endif | |
1250 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.) | |
1251 | ||
8b198102 FXC |
1252 | ! IEEE_SUPPORT_DIVIDE |
1253 | ||
1254 | SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.) | |
1255 | SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.) | |
1256 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1257 | SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.) |
8b198102 FXC |
1258 | #endif |
1259 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1260 | SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.) |
8b198102 | 1261 | #endif |
8b198102 | 1262 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.) |
8b198102 FXC |
1263 | |
1264 | ! IEEE_SUPPORT_INF | |
1265 | ||
1266 | SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.) | |
1267 | SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.) | |
1268 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1269 | SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.) |
8b198102 FXC |
1270 | #endif |
1271 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1272 | SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.) |
8b198102 | 1273 | #endif |
8b198102 | 1274 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.) |
8b198102 FXC |
1275 | |
1276 | ! IEEE_SUPPORT_IO | |
1277 | ||
1278 | SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.) | |
1279 | SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.) | |
1280 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1281 | SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.) |
8b198102 FXC |
1282 | #endif |
1283 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1284 | SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.) |
8b198102 | 1285 | #endif |
8b198102 | 1286 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.) |
8b198102 FXC |
1287 | |
1288 | ! IEEE_SUPPORT_NAN | |
1289 | ||
1290 | SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.) | |
1291 | SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.) | |
1292 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1293 | SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.) |
8b198102 FXC |
1294 | #endif |
1295 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1296 | SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.) |
8b198102 | 1297 | #endif |
8b198102 | 1298 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.) |
8b198102 FXC |
1299 | |
1300 | ! IEEE_SUPPORT_SQRT | |
1301 | ||
1302 | SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.) | |
1303 | SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.) | |
1304 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1305 | SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.) |
8b198102 FXC |
1306 | #endif |
1307 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1308 | SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.) |
8b198102 | 1309 | #endif |
8b198102 | 1310 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.) |
8b198102 FXC |
1311 | |
1312 | ! IEEE_SUPPORT_STANDARD | |
1313 | ||
1314 | SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.) | |
1315 | SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.) | |
1316 | #ifdef HAVE_GFC_REAL_10 | |
22a49988 | 1317 | SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.) |
8b198102 FXC |
1318 | #endif |
1319 | #ifdef HAVE_GFC_REAL_16 | |
22a49988 | 1320 | SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.) |
8b198102 | 1321 | #endif |
8b198102 | 1322 | SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.) |
8b198102 | 1323 | |
8b198102 | 1324 | end module IEEE_ARITHMETIC |