]> gcc.gnu.org Git - gcc.git/blame - libgfortran/ieee/ieee_arithmetic.F90
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
[gcc.git] / libgfortran / ieee / ieee_arithmetic.F90
CommitLineData
8b198102 1! Implementation of the IEEE_ARITHMETIC standard intrinsic module
83ffe9cd 2! Copyright (C) 2013-2023 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
31module 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
17bccd1d
FXC		 226 ! IEEE_MIN_NUM, IEEE_MAX_NUM, IEEE_MIN_NUM_MAG, IEEE_MAX_NUM_MAG
227
228 interface
229 elemental real(kind=4) function _gfortran_ieee_max_num_4(X, Y)
230 real(kind=4), intent(in) :: X, Y
231 end function
232 elemental real(kind=8) function _gfortran_ieee_max_num_8(X, Y)
233 real(kind=8), intent(in) :: X, Y
234 end function
235#ifdef HAVE_GFC_REAL_10
236 elemental real(kind=10) function _gfortran_ieee_max_num_10(X, Y)
237 real(kind=10), intent(in) :: X, Y
238 end function
239#endif
240#ifdef HAVE_GFC_REAL_16
241 elemental real(kind=16) function _gfortran_ieee_max_num_16(X, Y)
242 real(kind=16), intent(in) :: X, Y
243 end function
244#endif
245 end interface
246
247 interface IEEE_MAX_NUM
248 procedure &
249#ifdef HAVE_GFC_REAL_16
250 _gfortran_ieee_max_num_16, &
251#endif
252#ifdef HAVE_GFC_REAL_10
253 _gfortran_ieee_max_num_10, &
254#endif
255 _gfortran_ieee_max_num_8, _gfortran_ieee_max_num_4
256 end interface
257 public :: IEEE_MAX_NUM
258
259 interface
260 elemental real(kind=4) function _gfortran_ieee_max_num_mag_4(X, Y)
261 real(kind=4), intent(in) :: X, Y
262 end function
263 elemental real(kind=8) function _gfortran_ieee_max_num_mag_8(X, Y)
264 real(kind=8), intent(in) :: X, Y
265 end function
266#ifdef HAVE_GFC_REAL_10
267 elemental real(kind=10) function _gfortran_ieee_max_num_mag_10(X, Y)
268 real(kind=10), intent(in) :: X, Y
269 end function
270#endif
271#ifdef HAVE_GFC_REAL_16
272 elemental real(kind=16) function _gfortran_ieee_max_num_mag_16(X, Y)
273 real(kind=16), intent(in) :: X, Y
274 end function
275#endif
276 end interface
277
278 interface IEEE_MAX_NUM_MAG
279 procedure &
280#ifdef HAVE_GFC_REAL_16
281 _gfortran_ieee_max_num_mag_16, &
282#endif
283#ifdef HAVE_GFC_REAL_10
284 _gfortran_ieee_max_num_mag_10, &
285#endif
286 _gfortran_ieee_max_num_mag_8, _gfortran_ieee_max_num_mag_4
287 end interface
288 public :: IEEE_MAX_NUM_MAG
289
290 interface
291 elemental real(kind=4) function _gfortran_ieee_min_num_4(X, Y)
292 real(kind=4), intent(in) :: X, Y
293 end function
294 elemental real(kind=8) function _gfortran_ieee_min_num_8(X, Y)
295 real(kind=8), intent(in) :: X, Y
296 end function
297#ifdef HAVE_GFC_REAL_10
298 elemental real(kind=10) function _gfortran_ieee_min_num_10(X, Y)
299 real(kind=10), intent(in) :: X, Y
300 end function
301#endif
302#ifdef HAVE_GFC_REAL_16
303 elemental real(kind=16) function _gfortran_ieee_min_num_16(X, Y)
304 real(kind=16), intent(in) :: X, Y
305 end function
306#endif
307 end interface
308
309 interface IEEE_MIN_NUM
310 procedure &
311#ifdef HAVE_GFC_REAL_16
312 _gfortran_ieee_min_num_16, &
313#endif
314#ifdef HAVE_GFC_REAL_10
315 _gfortran_ieee_min_num_10, &
316#endif
317 _gfortran_ieee_min_num_8, _gfortran_ieee_min_num_4
318 end interface
319 public :: IEEE_MIN_NUM
320
321 interface
322 elemental real(kind=4) function _gfortran_ieee_min_num_mag_4(X, Y)
323 real(kind=4), intent(in) :: X, Y
324 end function
325 elemental real(kind=8) function _gfortran_ieee_min_num_mag_8(X, Y)
326 real(kind=8), intent(in) :: X, Y
327 end function
328#ifdef HAVE_GFC_REAL_10
329 elemental real(kind=10) function _gfortran_ieee_min_num_mag_10(X, Y)
330 real(kind=10), intent(in) :: X, Y
331 end function
332#endif
333#ifdef HAVE_GFC_REAL_16
334 elemental real(kind=16) function _gfortran_ieee_min_num_mag_16(X, Y)
335 real(kind=16), intent(in) :: X, Y
336 end function
337#endif
338 end interface
339
340 interface IEEE_MIN_NUM_MAG
341 procedure &
342#ifdef HAVE_GFC_REAL_16
343 _gfortran_ieee_min_num_mag_16, &
344#endif
345#ifdef HAVE_GFC_REAL_10
346 _gfortran_ieee_min_num_mag_10, &
347#endif
348 _gfortran_ieee_min_num_mag_8, _gfortran_ieee_min_num_mag_4
349 end interface
350 public :: IEEE_MIN_NUM_MAG
351
8b198102
FXC		 352 ! IEEE_COPY_SIGN
353
22a49988
FXC		 354#define COPYSIGN_MACRO(A,B) \
355 elemental real(kind = A) function \
356 _gfortran_ieee_copy_sign_/**/A/**/_/**/B (X,Y) ; \
357 real(kind = A), intent(in) :: X ; \
358 real(kind = B), intent(in) :: Y ; \
359 end function
360
8b198102 361 interface
22a49988 362#ifdef HAVE_GFC_REAL_16
11e07fa4 363COPYSIGN_MACRO(16,16)
22a49988 364#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 365COPYSIGN_MACRO(16,10)
366COPYSIGN_MACRO(10,16)
22a49988 367#endif
11e07fa4
SK		 368COPYSIGN_MACRO(16,8)
369COPYSIGN_MACRO(16,4)
22a49988 370COPYSIGN_MACRO(8,16)
11e07fa4 371COPYSIGN_MACRO(4,16)
22a49988
FXC		 372#endif
373#ifdef HAVE_GFC_REAL_10
22a49988 374COPYSIGN_MACRO(10,10)
11e07fa4
SK		 375COPYSIGN_MACRO(10,8)
376COPYSIGN_MACRO(10,4)
377COPYSIGN_MACRO(8,10)
378COPYSIGN_MACRO(4,10)
22a49988 379#endif
11e07fa4
SK		 380COPYSIGN_MACRO(8,8)
381COPYSIGN_MACRO(8,4)
382COPYSIGN_MACRO(4,8)
383COPYSIGN_MACRO(4,4)
8b198102
FXC		 384 end interface
385
386 interface IEEE_COPY_SIGN
22a49988
FXC		 387 procedure &
388#ifdef HAVE_GFC_REAL_16
389 _gfortran_ieee_copy_sign_16_16, &
390#ifdef HAVE_GFC_REAL_10
391 _gfortran_ieee_copy_sign_16_10, &
11e07fa4 392 _gfortran_ieee_copy_sign_10_16, &
22a49988
FXC		 393#endif
394 _gfortran_ieee_copy_sign_16_8, &
395 _gfortran_ieee_copy_sign_16_4, &
11e07fa4
SK		 396 _gfortran_ieee_copy_sign_8_16, &
397 _gfortran_ieee_copy_sign_4_16, &
22a49988
FXC		 398#endif
399#ifdef HAVE_GFC_REAL_10
22a49988
FXC		 400 _gfortran_ieee_copy_sign_10_10, &
401 _gfortran_ieee_copy_sign_10_8, &
402 _gfortran_ieee_copy_sign_10_4, &
22a49988 403 _gfortran_ieee_copy_sign_8_10, &
11e07fa4 404 _gfortran_ieee_copy_sign_4_10, &
22a49988
FXC		 405#endif
406 _gfortran_ieee_copy_sign_8_8, &
407 _gfortran_ieee_copy_sign_8_4, &
22a49988
FXC		 408 _gfortran_ieee_copy_sign_4_8, &
409 _gfortran_ieee_copy_sign_4_4
8b198102
FXC		 410 end interface
411 public :: IEEE_COPY_SIGN
412
413 ! IEEE_UNORDERED
414
22a49988
FXC		 415#define UNORDERED_MACRO(A,B) \
416 elemental logical function \
417 _gfortran_ieee_unordered_/**/A/**/_/**/B (X,Y) ; \
418 real(kind = A), intent(in) :: X ; \
419 real(kind = B), intent(in) :: Y ; \
420 end function
421
8b198102 422 interface
22a49988 423#ifdef HAVE_GFC_REAL_16
11e07fa4 424UNORDERED_MACRO(16,16)
22a49988 425#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 426UNORDERED_MACRO(16,10)
427UNORDERED_MACRO(10,16)
22a49988 428#endif
11e07fa4
SK		 429UNORDERED_MACRO(16,8)
430UNORDERED_MACRO(16,4)
22a49988 431UNORDERED_MACRO(8,16)
11e07fa4 432UNORDERED_MACRO(4,16)
22a49988
FXC		 433#endif
434#ifdef HAVE_GFC_REAL_10
22a49988 435UNORDERED_MACRO(10,10)
11e07fa4
SK		 436UNORDERED_MACRO(10,8)
437UNORDERED_MACRO(10,4)
438UNORDERED_MACRO(8,10)
439UNORDERED_MACRO(4,10)
22a49988 440#endif
11e07fa4
SK		 441UNORDERED_MACRO(8,8)
442UNORDERED_MACRO(8,4)
443UNORDERED_MACRO(4,8)
444UNORDERED_MACRO(4,4)
8b198102
FXC		 445 end interface
446
447 interface IEEE_UNORDERED
22a49988
FXC		 448 procedure &
449#ifdef HAVE_GFC_REAL_16
450 _gfortran_ieee_unordered_16_16, &
451#ifdef HAVE_GFC_REAL_10
452 _gfortran_ieee_unordered_16_10, &
11e07fa4 453 _gfortran_ieee_unordered_10_16, &
22a49988
FXC		 454#endif
455 _gfortran_ieee_unordered_16_8, &
456 _gfortran_ieee_unordered_16_4, &
11e07fa4
SK		 457 _gfortran_ieee_unordered_8_16, &
458 _gfortran_ieee_unordered_4_16, &
22a49988
FXC		 459#endif
460#ifdef HAVE_GFC_REAL_10
22a49988
FXC		 461 _gfortran_ieee_unordered_10_10, &
462 _gfortran_ieee_unordered_10_8, &
463 _gfortran_ieee_unordered_10_4, &
22a49988 464 _gfortran_ieee_unordered_8_10, &
11e07fa4 465 _gfortran_ieee_unordered_4_10, &
22a49988
FXC		 466#endif
467 _gfortran_ieee_unordered_8_8, &
468 _gfortran_ieee_unordered_8_4, &
22a49988
FXC		 469 _gfortran_ieee_unordered_4_8, &
470 _gfortran_ieee_unordered_4_4
8b198102
FXC		 471 end interface
472 public :: IEEE_UNORDERED
473
7c4c65d1
FXC		 474 ! IEEE_FMA
475
476 interface
477 elemental real(kind=4) function _gfortran_ieee_fma_4 (A, B, C)
478 real(kind=4), intent(in) :: A, B, C
479 end function
480 elemental real(kind=8) function _gfortran_ieee_fma_8 (A, B, C)
481 real(kind=8), intent(in) :: A, B, C
482 end function
483#ifdef HAVE_GFC_REAL_10
484 elemental real(kind=10) function _gfortran_ieee_fma_10 (A, B, C)
485 real(kind=10), intent(in) :: A, B, C
486 end function
487#endif
488#ifdef HAVE_GFC_REAL_16
489 elemental real(kind=16) function _gfortran_ieee_fma_16 (A, B, C)
490 real(kind=16), intent(in) :: A, B, C
491 end function
492#endif
493 end interface
494
495 interface IEEE_FMA
496 procedure &
497#ifdef HAVE_GFC_REAL_16
498 _gfortran_ieee_fma_16, &
499#endif
500#ifdef HAVE_GFC_REAL_10
501 _gfortran_ieee_fma_10, &
502#endif
503 _gfortran_ieee_fma_8, _gfortran_ieee_fma_4
504 end interface
505 public :: IEEE_FMA
506
dca28748
FXC		 507 ! IEEE_QUIET_* and IEEE_SIGNALING_* comparison functions
508
509#define COMP_MACRO(TYPE,OP,K) \
510 elemental logical function \
511 _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_/**/K (X,Y) ; \
512 real(kind = K), intent(in) :: X ; \
513 real(kind = K), intent(in) :: Y ; \
514 end function
515
516#ifdef HAVE_GFC_REAL_16
517# define EXPAND_COMP_MACRO_16(TYPE,OP) COMP_MACRO(TYPE,OP,16)
518#else
519# define EXPAND_COMP_MACRO_16(TYPE,OP)
520#endif
521
522#undef EXPAND_MACRO_10
523#ifdef HAVE_GFC_REAL_10
524# define EXPAND_COMP_MACRO_10(TYPE,OP) COMP_MACRO(TYPE,OP,10)
525#else
526# define EXPAND_COMP_MACRO_10(TYPE,OP)
527#endif
528
529#define COMP_FUNCTION(TYPE,OP) \
530 interface ; \
531 COMP_MACRO(TYPE,OP,4) ; \
532 COMP_MACRO(TYPE,OP,8) ; \
533 EXPAND_COMP_MACRO_10(TYPE,OP) ; \
534 EXPAND_COMP_MACRO_16(TYPE,OP) ; \
535 end interface
536
537#ifdef HAVE_GFC_REAL_16
538# define EXPAND_INTER_MACRO_16(TYPE,OP) _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_16
539#else
540# define EXPAND_INTER_MACRO_16(TYPE,OP)
541#endif
542
543#ifdef HAVE_GFC_REAL_10
544# define EXPAND_INTER_MACRO_10(TYPE,OP) _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_10
545#else
546# define EXPAND_INTER_MACRO_10(TYPE,OP)
547#endif
548
549#define COMP_INTERFACE(TYPE,OP) \
550 interface IEEE_/**/TYPE/**/_/**/OP ; \
551 procedure \
552 EXPAND_INTER_MACRO_16(TYPE,OP) , \
553 EXPAND_INTER_MACRO_10(TYPE,OP) , \
554 _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_8 , \
555 _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_4 ; \
556 end interface ; \
557 public :: IEEE_/**/TYPE/**/_/**/OP
558
559#define IEEE_COMPARISON(TYPE,OP) \
560 COMP_FUNCTION(TYPE,OP) ; \
561 COMP_INTERFACE(TYPE,OP)
562
563 IEEE_COMPARISON(QUIET,EQ)
564 IEEE_COMPARISON(QUIET,GE)
565 IEEE_COMPARISON(QUIET,GT)
566 IEEE_COMPARISON(QUIET,LE)
567 IEEE_COMPARISON(QUIET,LT)
568 IEEE_COMPARISON(QUIET,NE)
569 IEEE_COMPARISON(SIGNALING,EQ)
570 IEEE_COMPARISON(SIGNALING,GE)
571 IEEE_COMPARISON(SIGNALING,GT)
572 IEEE_COMPARISON(SIGNALING,LE)
573 IEEE_COMPARISON(SIGNALING,LT)
574 IEEE_COMPARISON(SIGNALING,NE)
575
8b198102
FXC		 576 ! IEEE_LOGB
577
578 interface
579 elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
580 real(kind=4), intent(in) :: X
581 end function
582 elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
583 real(kind=8), intent(in) :: X
584 end function
22a49988
FXC		 585#ifdef HAVE_GFC_REAL_10
586 elemental real(kind=10) function _gfortran_ieee_logb_10 (X)
587 real(kind=10), intent(in) :: X
588 end function
589#endif
590#ifdef HAVE_GFC_REAL_16
591 elemental real(kind=16) function _gfortran_ieee_logb_16 (X)
592 real(kind=16), intent(in) :: X
593 end function
594#endif
8b198102
FXC		 595 end interface
596
597 interface IEEE_LOGB
22a49988
FXC		 598 procedure &
599#ifdef HAVE_GFC_REAL_16
600 _gfortran_ieee_logb_16, &
601#endif
602#ifdef HAVE_GFC_REAL_10
603 _gfortran_ieee_logb_10, &
604#endif
605 _gfortran_ieee_logb_8, &
606 _gfortran_ieee_logb_4
8b198102
FXC		 607 end interface
608 public :: IEEE_LOGB
609
610 ! IEEE_NEXT_AFTER
611
22a49988
FXC		 612#define NEXT_AFTER_MACRO(A,B) \
613 elemental real(kind = A) function \
614 _gfortran_ieee_next_after_/**/A/**/_/**/B (X,Y) ; \
615 real(kind = A), intent(in) :: X ; \
616 real(kind = B), intent(in) :: Y ; \
617 end function
618
8b198102 619 interface
22a49988 620#ifdef HAVE_GFC_REAL_16
11e07fa4 621NEXT_AFTER_MACRO(16,16)
22a49988 622#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 623NEXT_AFTER_MACRO(16,10)
624NEXT_AFTER_MACRO(10,16)
22a49988 625#endif
11e07fa4
SK		 626NEXT_AFTER_MACRO(16,8)
627NEXT_AFTER_MACRO(16,4)
22a49988 628NEXT_AFTER_MACRO(8,16)
11e07fa4 629NEXT_AFTER_MACRO(4,16)
22a49988
FXC		 630#endif
631#ifdef HAVE_GFC_REAL_10
22a49988 632NEXT_AFTER_MACRO(10,10)
11e07fa4
SK		 633NEXT_AFTER_MACRO(10,8)
634NEXT_AFTER_MACRO(10,4)
635NEXT_AFTER_MACRO(8,10)
636NEXT_AFTER_MACRO(4,10)
22a49988 637#endif
11e07fa4
SK		 638NEXT_AFTER_MACRO(8,8)
639NEXT_AFTER_MACRO(8,4)
640NEXT_AFTER_MACRO(4,8)
641NEXT_AFTER_MACRO(4,4)
8b198102
FXC		 642 end interface
643
644 interface IEEE_NEXT_AFTER
22a49988
FXC		 645 procedure &
646#ifdef HAVE_GFC_REAL_16
647 _gfortran_ieee_next_after_16_16, &
648#ifdef HAVE_GFC_REAL_10
649 _gfortran_ieee_next_after_16_10, &
11e07fa4 650 _gfortran_ieee_next_after_10_16, &
22a49988
FXC		 651#endif
652 _gfortran_ieee_next_after_16_8, &
653 _gfortran_ieee_next_after_16_4, &
11e07fa4
SK		 654 _gfortran_ieee_next_after_8_16, &
655 _gfortran_ieee_next_after_4_16, &
22a49988
FXC		 656#endif
657#ifdef HAVE_GFC_REAL_10
22a49988
FXC		 658 _gfortran_ieee_next_after_10_10, &
659 _gfortran_ieee_next_after_10_8, &
660 _gfortran_ieee_next_after_10_4, &
22a49988 661 _gfortran_ieee_next_after_8_10, &
11e07fa4 662 _gfortran_ieee_next_after_4_10, &
22a49988
FXC		 663#endif
664 _gfortran_ieee_next_after_8_8, &
665 _gfortran_ieee_next_after_8_4, &
22a49988
FXC		 666 _gfortran_ieee_next_after_4_8, &
667 _gfortran_ieee_next_after_4_4
8b198102
FXC		 668 end interface
669 public :: IEEE_NEXT_AFTER
670
671 ! IEEE_REM
672
22a49988
FXC		 673#define REM_MACRO(RES,A,B) \
674 elemental real(kind = RES) function \
675 _gfortran_ieee_rem_/**/A/**/_/**/B (X,Y) ; \
676 real(kind = A), intent(in) :: X ; \
677 real(kind = B), intent(in) :: Y ; \
678 end function
679
8b198102 680 interface
22a49988 681#ifdef HAVE_GFC_REAL_16
11e07fa4 682REM_MACRO(16,16,16)
22a49988 683#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 684REM_MACRO(16,16,10)
685REM_MACRO(16,10,16)
22a49988 686#endif
11e07fa4
SK		 687REM_MACRO(16,16,8)
688REM_MACRO(16,16,4)
22a49988 689REM_MACRO(16,8,16)
11e07fa4 690REM_MACRO(16,4,16)
22a49988
FXC		 691#endif
692#ifdef HAVE_GFC_REAL_10
22a49988 693REM_MACRO(10,10,10)
11e07fa4
SK		 694REM_MACRO(10,10,8)
695REM_MACRO(10,10,4)
696REM_MACRO(10,8,10)
697REM_MACRO(10,4,10)
22a49988 698#endif
11e07fa4
SK		 699REM_MACRO(8,8,8)
700REM_MACRO(8,8,4)
701REM_MACRO(8,4,8)
702REM_MACRO(4,4,4)
8b198102
FXC		 703 end interface
704
705 interface IEEE_REM
22a49988
FXC		 706 procedure &
707#ifdef HAVE_GFC_REAL_16
708 _gfortran_ieee_rem_16_16, &
709#ifdef HAVE_GFC_REAL_10
710 _gfortran_ieee_rem_16_10, &
11e07fa4 711 _gfortran_ieee_rem_10_16, &
22a49988
FXC		 712#endif
713 _gfortran_ieee_rem_16_8, &
714 _gfortran_ieee_rem_16_4, &
11e07fa4
SK		 715 _gfortran_ieee_rem_8_16, &
716 _gfortran_ieee_rem_4_16, &
22a49988
FXC		 717#endif
718#ifdef HAVE_GFC_REAL_10
22a49988
FXC		 719 _gfortran_ieee_rem_10_10, &
720 _gfortran_ieee_rem_10_8, &
721 _gfortran_ieee_rem_10_4, &
22a49988 722 _gfortran_ieee_rem_8_10, &
11e07fa4 723 _gfortran_ieee_rem_4_10, &
22a49988
FXC		 724#endif
725 _gfortran_ieee_rem_8_8, &
726 _gfortran_ieee_rem_8_4, &
22a49988
FXC		 727 _gfortran_ieee_rem_4_8, &
728 _gfortran_ieee_rem_4_4
8b198102
FXC		 729 end interface
730 public :: IEEE_REM
731
732 ! IEEE_RINT
733
734 interface
735 elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
736 real(kind=4), intent(in) :: X
737 end function
738 elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
739 real(kind=8), intent(in) :: X
740 end function
22a49988
FXC		 741#ifdef HAVE_GFC_REAL_10
742 elemental real(kind=10) function _gfortran_ieee_rint_10 (X)
743 real(kind=10), intent(in) :: X
744 end function
745#endif
746#ifdef HAVE_GFC_REAL_16
747 elemental real(kind=16) function _gfortran_ieee_rint_16 (X)
748 real(kind=16), intent(in) :: X
749 end function
750#endif
8b198102
FXC		 751 end interface
752
753 interface IEEE_RINT
22a49988
FXC		 754 procedure &
755#ifdef HAVE_GFC_REAL_16
756 _gfortran_ieee_rint_16, &
757#endif
758#ifdef HAVE_GFC_REAL_10
759 _gfortran_ieee_rint_10, &
760#endif
761 _gfortran_ieee_rint_8, _gfortran_ieee_rint_4
8b198102
FXC		 762 end interface
763 public :: IEEE_RINT
764
765 ! IEEE_SCALB
766
767 interface
8ab8b08a
SK		 768#ifdef HAVE_GFC_INTEGER_16
769#ifdef HAVE_GFC_REAL_16
770 elemental real(kind=16) function _gfortran_ieee_scalb_16_16 (X, I)
771 real(kind=16), intent(in) :: X
772 integer(kind=16), intent(in) :: I
773 end function
774#endif
775#ifdef HAVE_GFC_REAL_10
776 elemental real(kind=10) function _gfortran_ieee_scalb_10_16 (X, I)
777 real(kind=10), intent(in) :: X
778 integer(kind=16), intent(in) :: I
779 end function
780#endif
781 elemental real(kind=8) function _gfortran_ieee_scalb_8_16 (X, I)
782 real(kind=8), intent(in) :: X
783 integer(kind=16), intent(in) :: I
784 end function
785 elemental real(kind=4) function _gfortran_ieee_scalb_4_16 (X, I)
8b198102 786 real(kind=4), intent(in) :: X
8ab8b08a 787 integer(kind=16), intent(in) :: I
8b198102 788 end function
8ab8b08a
SK		 789#endif
790
791#ifdef HAVE_GFC_INTEGER_8
792#ifdef HAVE_GFC_REAL_16
793 elemental real(kind=16) function _gfortran_ieee_scalb_16_8 (X, I)
794 real(kind=16), intent(in) :: X
795 integer(kind=8), intent(in) :: I
796 end function
797#endif
798#ifdef HAVE_GFC_REAL_10
799 elemental real(kind=10) function _gfortran_ieee_scalb_10_8 (X, I)
800 real(kind=10), intent(in) :: X
801 integer(kind=8), intent(in) :: I
802 end function
803#endif
804 elemental real(kind=8) function _gfortran_ieee_scalb_8_8 (X, I)
8b198102 805 real(kind=8), intent(in) :: X
8ab8b08a
SK		 806 integer(kind=8), intent(in) :: I
807 end function
808 elemental real(kind=4) function _gfortran_ieee_scalb_4_8 (X, I)
809 real(kind=4), intent(in) :: X
810 integer(kind=8), intent(in) :: I
811 end function
812#endif
813
814#ifdef HAVE_GFC_INTEGER_2
815#ifdef HAVE_GFC_REAL_16
816 elemental real(kind=16) function _gfortran_ieee_scalb_16_2 (X, I)
817 real(kind=16), intent(in) :: X
818 integer(kind=2), intent(in) :: I
8b198102 819 end function
8ab8b08a 820#endif
22a49988 821#ifdef HAVE_GFC_REAL_10
8ab8b08a 822 elemental real(kind=10) function _gfortran_ieee_scalb_10_2 (X, I)
22a49988 823 real(kind=10), intent(in) :: X
8ab8b08a
SK		 824 integer(kind=2), intent(in) :: I
825 end function
826#endif
827 elemental real(kind=8) function _gfortran_ieee_scalb_8_2 (X, I)
828 real(kind=8), intent(in) :: X
829 integer(kind=2), intent(in) :: I
830 end function
831 elemental real(kind=4) function _gfortran_ieee_scalb_4_2 (X, I)
832 real(kind=4), intent(in) :: X
833 integer(kind=2), intent(in) :: I
834 end function
835#endif
836
837#ifdef HAVE_GFC_INTEGER_1
838#ifdef HAVE_GFC_REAL_16
839 elemental real(kind=16) function _gfortran_ieee_scalb_16_1 (X, I)
840 real(kind=16), intent(in) :: X
841 integer(kind=1), intent(in) :: I
22a49988
FXC		 842 end function
843#endif
8ab8b08a
SK		 844#ifdef HAVE_GFC_REAL_10
845 elemental real(kind=10) function _gfortran_ieee_scalb_10_1 (X, I)
846 real(kind=10), intent(in) :: X
847 integer(kind=1), intent(in) :: I
848 end function
849#endif
850 elemental real(kind=8) function _gfortran_ieee_scalb_8_1 (X, I)
851 real(kind=8), intent(in) :: X
852 integer(kind=1), intent(in) :: I
853 end function
854 elemental real(kind=4) function _gfortran_ieee_scalb_4_1 (X, I)
855 real(kind=4), intent(in) :: X
856 integer(kind=1), intent(in) :: I
857 end function
858#endif
859
22a49988 860#ifdef HAVE_GFC_REAL_16
8ab8b08a 861 elemental real(kind=16) function _gfortran_ieee_scalb_16_4 (X, I)
22a49988
FXC		 862 real(kind=16), intent(in) :: X
863 integer, intent(in) :: I
864 end function
865#endif
8ab8b08a
SK		 866#ifdef HAVE_GFC_REAL_10
867 elemental real(kind=10) function _gfortran_ieee_scalb_10_4 (X, I)
868 real(kind=10), intent(in) :: X
869 integer, intent(in) :: I
870 end function
871#endif
872 elemental real(kind=8) function _gfortran_ieee_scalb_8_4 (X, I)
873 real(kind=8), intent(in) :: X
874 integer, intent(in) :: I
875 end function
876 elemental real(kind=4) function _gfortran_ieee_scalb_4_4 (X, I)
877 real(kind=4), intent(in) :: X
878 integer, intent(in) :: I
879 end function
8b198102
FXC		 880 end interface
881
882 interface IEEE_SCALB
22a49988 883 procedure &
8ab8b08a
SK		 884#ifdef HAVE_GFC_INTEGER_16
885#ifdef HAVE_GFC_REAL_16
886 _gfortran_ieee_scalb_16_16, &
887#endif
888#ifdef HAVE_GFC_REAL_10
889 _gfortran_ieee_scalb_10_16, &
890#endif
891 _gfortran_ieee_scalb_8_16, &
892 _gfortran_ieee_scalb_4_16, &
893#endif
894#ifdef HAVE_GFC_INTEGER_8
895#ifdef HAVE_GFC_REAL_16
896 _gfortran_ieee_scalb_16_8, &
897#endif
898#ifdef HAVE_GFC_REAL_10
899 _gfortran_ieee_scalb_10_8, &
900#endif
901 _gfortran_ieee_scalb_8_8, &
902 _gfortran_ieee_scalb_4_8, &
903#endif
904#ifdef HAVE_GFC_INTEGER_2
905#ifdef HAVE_GFC_REAL_16
906 _gfortran_ieee_scalb_16_2, &
907#endif
908#ifdef HAVE_GFC_REAL_10
909 _gfortran_ieee_scalb_10_2, &
910#endif
911 _gfortran_ieee_scalb_8_2, &
912 _gfortran_ieee_scalb_4_2, &
913#endif
914#ifdef HAVE_GFC_INTEGER_1
915#ifdef HAVE_GFC_REAL_16
916 _gfortran_ieee_scalb_16_1, &
917#endif
918#ifdef HAVE_GFC_REAL_10
919 _gfortran_ieee_scalb_10_1, &
920#endif
921 _gfortran_ieee_scalb_8_1, &
922 _gfortran_ieee_scalb_4_1, &
923#endif
22a49988 924#ifdef HAVE_GFC_REAL_16
8ab8b08a 925 _gfortran_ieee_scalb_16_4, &
22a49988
FXC		 926#endif
927#ifdef HAVE_GFC_REAL_10
8ab8b08a 928 _gfortran_ieee_scalb_10_4, &
22a49988 929#endif
8ab8b08a
SK		 930 _gfortran_ieee_scalb_8_4, &
931 _gfortran_ieee_scalb_4_4
8b198102
FXC		 932 end interface
933 public :: IEEE_SCALB
934
7c4c65d1
FXC		 935 ! IEEE_SIGNBIT
936
937 interface
938 elemental logical function _gfortran_ieee_signbit_4 (X)
939 real(kind=4), intent(in) :: X
940 end function
941 elemental logical function _gfortran_ieee_signbit_8 (X)
942 real(kind=8), intent(in) :: X
943 end function
944#ifdef HAVE_GFC_REAL_10
945 elemental logical function _gfortran_ieee_signbit_10 (X)
946 real(kind=10), intent(in) :: X
947 end function
948#endif
949#ifdef HAVE_GFC_REAL_16
950 elemental logical function _gfortran_ieee_signbit_16 (X)
951 real(kind=16), intent(in) :: X
952 end function
953#endif
954 end interface
955
956 interface IEEE_SIGNBIT
957 procedure &
958#ifdef HAVE_GFC_REAL_16
959 _gfortran_ieee_signbit_16, &
960#endif
961#ifdef HAVE_GFC_REAL_10
962 _gfortran_ieee_signbit_10, &
963#endif
964 _gfortran_ieee_signbit_8, _gfortran_ieee_signbit_4
965 end interface
966 public :: IEEE_SIGNBIT
967
8b198102
FXC		 968 ! IEEE_VALUE
969
970 interface IEEE_VALUE
22a49988
FXC		 971 module procedure &
972#ifdef HAVE_GFC_REAL_16
973 IEEE_VALUE_16, &
974#endif
975#ifdef HAVE_GFC_REAL_10
976 IEEE_VALUE_10, &
977#endif
978 IEEE_VALUE_8, IEEE_VALUE_4
8b198102
FXC		 979 end interface
980 public :: IEEE_VALUE
981
982 ! IEEE_CLASS
983
984 interface IEEE_CLASS
22a49988
FXC		 985 module procedure &
986#ifdef HAVE_GFC_REAL_16
987 IEEE_CLASS_16, &
988#endif
989#ifdef HAVE_GFC_REAL_10
990 IEEE_CLASS_10, &
991#endif
992 IEEE_CLASS_8, IEEE_CLASS_4
8b198102
FXC		 993 end interface
994 public :: IEEE_CLASS
995
996 ! Public declarations for contained procedures
997 public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
998 public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
999 public :: IEEE_SELECTED_REAL_KIND
1000
1001 ! IEEE_SUPPORT_ROUNDING
1002
1003 interface IEEE_SUPPORT_ROUNDING
1004 module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
1005#ifdef HAVE_GFC_REAL_10
1006 IEEE_SUPPORT_ROUNDING_10, &
1007#endif
1008#ifdef HAVE_GFC_REAL_16
1009 IEEE_SUPPORT_ROUNDING_16, &
1010#endif
1011 IEEE_SUPPORT_ROUNDING_NOARG
1012 end interface
1013 public :: IEEE_SUPPORT_ROUNDING
519196a2 1014
8b198102
FXC		 1015 ! Interface to the FPU-specific function
1016 interface
1017 pure integer function support_rounding_helper(flag) &
1018 bind(c, name="_gfortrani_support_fpu_rounding_mode")
1019 integer, intent(in), value :: flag
1020 end function
1021 end interface
1022
f5168e47
FXC		 1023 ! IEEE_SUPPORT_UNDERFLOW_CONTROL
1024
1025 interface IEEE_SUPPORT_UNDERFLOW_CONTROL
1026 module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, &
1027 IEEE_SUPPORT_UNDERFLOW_CONTROL_8, &
1028#ifdef HAVE_GFC_REAL_10
1029 IEEE_SUPPORT_UNDERFLOW_CONTROL_10, &
1030#endif
1031#ifdef HAVE_GFC_REAL_16
1032 IEEE_SUPPORT_UNDERFLOW_CONTROL_16, &
1033#endif
1034 IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG
1035 end interface
1036 public :: IEEE_SUPPORT_UNDERFLOW_CONTROL
519196a2 1037
f5168e47
FXC		 1038 ! Interface to the FPU-specific function
1039 interface
1040 pure integer function support_underflow_control_helper(kind) &
1041 bind(c, name="_gfortrani_support_fpu_underflow_control")
1042 integer, intent(in), value :: kind
1043 end function
1044 end interface
1045
8b198102
FXC		 1046! IEEE_SUPPORT_* generic functions
1047
1048#if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
1049# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
1050#elif defined(HAVE_GFC_REAL_10)
1051# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
1052#elif defined(HAVE_GFC_REAL_16)
1053# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
1054#else
1055# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
1056#endif
1057
1058#define SUPPORTGENERIC(NAME) \
1059 interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
1060 public :: NAME
1061
1062SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
1063SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
ede9dea5 1064SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
8b198102
FXC		 1065SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
1066SUPPORTGENERIC(IEEE_SUPPORT_INF)
1067SUPPORTGENERIC(IEEE_SUPPORT_IO)
1068SUPPORTGENERIC(IEEE_SUPPORT_NAN)
1069SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
1070SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
8b198102
FXC		 1071
1072contains
1073
1074 ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
1075 elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
1076 implicit none
1077 type(IEEE_CLASS_TYPE), intent(in) :: X, Y
1078 res = (X%hidden == Y%hidden)
1079 end function
1080
1081 elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
1082 implicit none
1083 type(IEEE_CLASS_TYPE), intent(in) :: X, Y
1084 res = (X%hidden /= Y%hidden)
1085 end function
1086
1087 elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
1088 implicit none
1089 type(IEEE_ROUND_TYPE), intent(in) :: X, Y
1090 res = (X%hidden == Y%hidden)
1091 end function
1092
1093 elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
1094 implicit none
1095 type(IEEE_ROUND_TYPE), intent(in) :: X, Y
1096 res = (X%hidden /= Y%hidden)
1097 end function
1098
22a49988 1099
8b198102 1100 ! IEEE_SELECTED_REAL_KIND
22a49988 1101
8b198102
FXC		 1102 integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
1103 implicit none
1104 integer, intent(in), optional :: P, R, RADIX
22a49988
FXC		 1105
1106 ! Currently, if IEEE is supported and this module is built, it means
1107 ! all our floating-point types conform to IEEE. Hence, we simply call
1108 ! SELECTED_REAL_KIND.
1109
1110 res = SELECTED_REAL_KIND (P, R, RADIX)
1111
8b198102
FXC		 1112 end function
1113
1114
1115 ! IEEE_CLASS
1116
1117 elemental function IEEE_CLASS_4 (X) result(res)
1118 implicit none
1119 real(kind=4), intent(in) :: X
1120 type(IEEE_CLASS_TYPE) :: res
1121
1122 interface
1123 pure integer function _gfortrani_ieee_class_helper_4(val)
1124 real(kind=4), intent(in) :: val
1125 end function
1126 end interface
1127
1128 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
1129 end function
1130
1131 elemental function IEEE_CLASS_8 (X) result(res)
1132 implicit none
1133 real(kind=8), intent(in) :: X
1134 type(IEEE_CLASS_TYPE) :: res
1135
1136 interface
1137 pure integer function _gfortrani_ieee_class_helper_8(val)
1138 real(kind=8), intent(in) :: val
1139 end function
1140 end interface
1141
1142 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
1143 end function
1144
22a49988
FXC		 1145#ifdef HAVE_GFC_REAL_10
1146 elemental function IEEE_CLASS_10 (X) result(res)
1147 implicit none
1148 real(kind=10), intent(in) :: X
1149 type(IEEE_CLASS_TYPE) :: res
1150
1151 interface
1152 pure integer function _gfortrani_ieee_class_helper_10(val)
1153 real(kind=10), intent(in) :: val
1154 end function
1155 end interface
1156
1157 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_10(X))
1158 end function
1159#endif
1160
1161#ifdef HAVE_GFC_REAL_16
1162 elemental function IEEE_CLASS_16 (X) result(res)
1163 implicit none
1164 real(kind=16), intent(in) :: X
1165 type(IEEE_CLASS_TYPE) :: res
1166
1167 interface
1168 pure integer function _gfortrani_ieee_class_helper_16(val)
1169 real(kind=16), intent(in) :: val
1170 end function
1171 end interface
1172
1173 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_16(X))
1174 end function
1175#endif
1176
1177
8b198102
FXC		 1178 ! IEEE_VALUE
1179
8a92685e 1180 elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
8b198102 1181 real(kind=4), intent(in) :: X
8a92685e 1182 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
90045c5d
FXC		 1183
1184 interface
1185 pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
1186 use ISO_C_BINDING, only: C_INT
1187 integer(kind=C_INT), value :: x
1188 end function
1189 end interface
1190
1191 res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
8b198102
FXC		 1192 end function
1193
8a92685e 1194 elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
8b198102 1195 real(kind=8), intent(in) :: X
8a92685e 1196 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
90045c5d
FXC		 1197
1198 interface
1199 pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
1200 use ISO_C_BINDING, only: C_INT
1201 integer(kind=C_INT), value :: x
1202 end function
1203 end interface
1204
1205 res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
8b198102
FXC		 1206 end function
1207
22a49988 1208#ifdef HAVE_GFC_REAL_10
8a92685e 1209 elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
22a49988 1210 real(kind=10), intent(in) :: X
8a92685e 1211 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
90045c5d
FXC		 1212
1213 interface
1214 pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
1215 use ISO_C_BINDING, only: C_INT
1216 integer(kind=C_INT), value :: x
1217 end function
1218 end interface
1219
1220 res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
22a49988 1221 end function
8a92685e 1222
22a49988
FXC		 1223#endif
1224
1225#ifdef HAVE_GFC_REAL_16
8a92685e 1226 elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
22a49988 1227 real(kind=16), intent(in) :: X
8a92685e 1228 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
90045c5d
FXC		 1229
1230 interface
1231 pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
1232 use ISO_C_BINDING, only: C_INT
1233 integer(kind=C_INT), value :: x
1234 end function
1235 end interface
1236
1237 res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
22a49988
FXC		 1238 end function
1239#endif
1240
8b198102
FXC		 1241
1242 ! IEEE_GET_ROUNDING_MODE
1243
4637a1d2 1244 subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE, RADIX)
8b198102
FXC		 1245 implicit none
1246 type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
4637a1d2 1247 integer, intent(in), optional :: RADIX
8b198102
FXC		 1248
1249 interface
1250 integer function helper() &
1251 bind(c, name="_gfortrani_get_fpu_rounding_mode")
1252 end function
1253 end interface
1254
f5168e47 1255 ROUND_VALUE = IEEE_ROUND_TYPE(helper())
8b198102
FXC		 1256 end subroutine
1257
1258
1259 ! IEEE_SET_ROUNDING_MODE
1260
4637a1d2 1261 subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE, RADIX)
8b198102
FXC		 1262 implicit none
1263 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
4637a1d2 1264 integer, intent(in), optional :: RADIX
8b198102
FXC		 1265
1266 interface
1267 subroutine helper(val) &
1268 bind(c, name="_gfortrani_set_fpu_rounding_mode")
1269 integer, value :: val
1270 end subroutine
1271 end interface
519196a2
FXC		 1272
1273 ! We do not support RADIX = 10, and such calls should not
1274 ! modify the binary rounding mode.
1275 if (present(RADIX)) then
1276 if (RADIX == 10) return
1277 end if
1278
8b198102
FXC		 1279 call helper(ROUND_VALUE%hidden)
1280 end subroutine
1281
1282
1283 ! IEEE_GET_UNDERFLOW_MODE
1284
1285 subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
1286 implicit none
1287 logical, intent(out) :: GRADUAL
f5168e47
FXC		 1288
1289 interface
1290 integer function helper() &
1291 bind(c, name="_gfortrani_get_fpu_underflow_mode")
1292 end function
1293 end interface
1294
1295 GRADUAL = (helper() /= 0)
8b198102
FXC		 1296 end subroutine
1297
1298
1299 ! IEEE_SET_UNDERFLOW_MODE
1300
1301 subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
1302 implicit none
1303 logical, intent(in) :: GRADUAL
f5168e47
FXC		 1304
1305 interface
1306 subroutine helper(val) &
1307 bind(c, name="_gfortrani_set_fpu_underflow_mode")
1308 integer, value :: val
1309 end subroutine
1310 end interface
1311
1312 call helper(merge(1, 0, GRADUAL))
8b198102
FXC		 1313 end subroutine
1314
1315! IEEE_SUPPORT_ROUNDING
1316
1317 pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
1318 implicit none
1319 real(kind=4), intent(in) :: X
1320 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1321 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1322 end function
1323
1324 pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
1325 implicit none
1326 real(kind=8), intent(in) :: X
1327 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1328 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1329 end function
1330
1331#ifdef HAVE_GFC_REAL_10
1332 pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
1333 implicit none
1334 real(kind=10), intent(in) :: X
1335 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
22a49988 1336 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
8b198102
FXC		 1337 end function
1338#endif
1339
1340#ifdef HAVE_GFC_REAL_16
1341 pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
1342 implicit none
1343 real(kind=16), intent(in) :: X
1344 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
22a49988 1345 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
8b198102
FXC		 1346 end function
1347#endif
1348
1349 pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
1350 implicit none
1351 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
8b198102 1352 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
8b198102
FXC		 1353 end function
1354
f5168e47
FXC		 1355! IEEE_SUPPORT_UNDERFLOW_CONTROL
1356
1357 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res)
1358 implicit none
1359 real(kind=4), intent(in) :: X
1360 res = (support_underflow_control_helper(4) /= 0)
1361 end function
1362
1363 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res)
1364 implicit none
1365 real(kind=8), intent(in) :: X
1366 res = (support_underflow_control_helper(8) /= 0)
1367 end function
1368
1369#ifdef HAVE_GFC_REAL_10
1370 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res)
1371 implicit none
1372 real(kind=10), intent(in) :: X
22a49988 1373 res = (support_underflow_control_helper(10) /= 0)
f5168e47
FXC		 1374 end function
1375#endif
1376
1377#ifdef HAVE_GFC_REAL_16
1378 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res)
1379 implicit none
1380 real(kind=16), intent(in) :: X
22a49988 1381 res = (support_underflow_control_helper(16) /= 0)
f5168e47
FXC		 1382 end function
1383#endif
1384
1385 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
1386 implicit none
f5168e47 1387 res = (support_underflow_control_helper(4) /= 0 &
22a49988
FXC		 1388 .and. support_underflow_control_helper(8) /= 0 &
1389#ifdef HAVE_GFC_REAL_10
1390 .and. support_underflow_control_helper(10) /= 0 &
1391#endif
1392#ifdef HAVE_GFC_REAL_16
1393 .and. support_underflow_control_helper(16) /= 0 &
f5168e47 1394#endif
22a49988 1395 )
f5168e47
FXC		 1396 end function
1397
8b198102
FXC		 1398! IEEE_SUPPORT_* functions
1399
1400#define SUPPORTMACRO(NAME, INTKIND, VALUE) \
1401 pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
1402 implicit none ; \
1403 real(INTKIND), intent(in) :: X(..) ; \
1404 res = VALUE ; \
1405 end function
1406
1407#define SUPPORTMACRO_NOARG(NAME, VALUE) \
1408 pure logical function NAME/**/_NOARG () result(res) ; \
1409 implicit none ; \
1410 res = VALUE ; \
1411 end function
1412
1413! IEEE_SUPPORT_DATATYPE
1414
1415SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
1416SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
1417#ifdef HAVE_GFC_REAL_10
22a49988 1418SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
8b198102
FXC		 1419#endif
1420#ifdef HAVE_GFC_REAL_16
22a49988 1421SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
8b198102 1422#endif
8b198102 1423SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
8b198102 1424
ede9dea5 1425! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
8b198102
FXC		 1426
1427SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
1428SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
1429#ifdef HAVE_GFC_REAL_10
22a49988 1430SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
8b198102
FXC		 1431#endif
1432#ifdef HAVE_GFC_REAL_16
22a49988 1433SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
8b198102 1434#endif
8b198102 1435SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
8b198102 1436
ede9dea5
SK		 1437SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
1438SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
1439#ifdef HAVE_GFC_REAL_10
1440SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
1441#endif
1442#ifdef HAVE_GFC_REAL_16
1443SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
1444#endif
1445SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
1446
8b198102
FXC		 1447! IEEE_SUPPORT_DIVIDE
1448
1449SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
1450SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
1451#ifdef HAVE_GFC_REAL_10
22a49988 1452SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
8b198102
FXC		 1453#endif
1454#ifdef HAVE_GFC_REAL_16
22a49988 1455SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
8b198102 1456#endif
8b198102 1457SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
8b198102
FXC		 1458
1459! IEEE_SUPPORT_INF
1460
1461SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
1462SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
1463#ifdef HAVE_GFC_REAL_10
22a49988 1464SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
8b198102
FXC		 1465#endif
1466#ifdef HAVE_GFC_REAL_16
22a49988 1467SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
8b198102 1468#endif
8b198102 1469SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
8b198102
FXC		 1470
1471! IEEE_SUPPORT_IO
1472
1473SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
1474SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
1475#ifdef HAVE_GFC_REAL_10
22a49988 1476SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
8b198102
FXC		 1477#endif
1478#ifdef HAVE_GFC_REAL_16
22a49988 1479SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
8b198102 1480#endif
8b198102 1481SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
8b198102
FXC		 1482
1483! IEEE_SUPPORT_NAN
1484
1485SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
1486SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
1487#ifdef HAVE_GFC_REAL_10
22a49988 1488SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
8b198102
FXC		 1489#endif
1490#ifdef HAVE_GFC_REAL_16
22a49988 1491SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
8b198102 1492#endif
8b198102 1493SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
8b198102
FXC		 1494
1495! IEEE_SUPPORT_SQRT
1496
1497SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
1498SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
1499#ifdef HAVE_GFC_REAL_10
22a49988 1500SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
8b198102
FXC		 1501#endif
1502#ifdef HAVE_GFC_REAL_16
22a49988 1503SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
8b198102 1504#endif
8b198102 1505SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
8b198102
FXC		 1506
1507! IEEE_SUPPORT_STANDARD
1508
1509SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
1510SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
1511#ifdef HAVE_GFC_REAL_10
22a49988 1512SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
8b198102
FXC		 1513#endif
1514#ifdef HAVE_GFC_REAL_16
22a49988 1515SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
8b198102 1516#endif
8b198102 1517SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
8b198102 1518
8b198102 1519end module IEEE_ARITHMETIC
GNU Compiler Collection
This page took 1.024347 seconds and 5 git commands to generate.