]> 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
Update copyright years.
[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
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 237COPYSIGN_MACRO(16,16)
22a49988 238#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 239COPYSIGN_MACRO(16,10)
240COPYSIGN_MACRO(10,16)
22a49988 241#endif
11e07fa4
SK		 242COPYSIGN_MACRO(16,8)
243COPYSIGN_MACRO(16,4)
22a49988 244COPYSIGN_MACRO(8,16)
11e07fa4 245COPYSIGN_MACRO(4,16)
22a49988
FXC		 246#endif
247#ifdef HAVE_GFC_REAL_10
22a49988 248COPYSIGN_MACRO(10,10)
11e07fa4
SK		 249COPYSIGN_MACRO(10,8)
250COPYSIGN_MACRO(10,4)
251COPYSIGN_MACRO(8,10)
252COPYSIGN_MACRO(4,10)
22a49988 253#endif
11e07fa4
SK		 254COPYSIGN_MACRO(8,8)
255COPYSIGN_MACRO(8,4)
256COPYSIGN_MACRO(4,8)
257COPYSIGN_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 298UNORDERED_MACRO(16,16)
22a49988 299#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 300UNORDERED_MACRO(16,10)
301UNORDERED_MACRO(10,16)
22a49988 302#endif
11e07fa4
SK		 303UNORDERED_MACRO(16,8)
304UNORDERED_MACRO(16,4)
22a49988 305UNORDERED_MACRO(8,16)
11e07fa4 306UNORDERED_MACRO(4,16)
22a49988
FXC		 307#endif
308#ifdef HAVE_GFC_REAL_10
22a49988 309UNORDERED_MACRO(10,10)
11e07fa4
SK		 310UNORDERED_MACRO(10,8)
311UNORDERED_MACRO(10,4)
312UNORDERED_MACRO(8,10)
313UNORDERED_MACRO(4,10)
22a49988 314#endif
11e07fa4
SK		 315UNORDERED_MACRO(8,8)
316UNORDERED_MACRO(8,4)
317UNORDERED_MACRO(4,8)
318UNORDERED_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 426NEXT_AFTER_MACRO(16,16)
22a49988 427#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 428NEXT_AFTER_MACRO(16,10)
429NEXT_AFTER_MACRO(10,16)
22a49988 430#endif
11e07fa4
SK		 431NEXT_AFTER_MACRO(16,8)
432NEXT_AFTER_MACRO(16,4)
22a49988 433NEXT_AFTER_MACRO(8,16)
11e07fa4 434NEXT_AFTER_MACRO(4,16)
22a49988
FXC		 435#endif
436#ifdef HAVE_GFC_REAL_10
22a49988 437NEXT_AFTER_MACRO(10,10)
11e07fa4
SK		 438NEXT_AFTER_MACRO(10,8)
439NEXT_AFTER_MACRO(10,4)
440NEXT_AFTER_MACRO(8,10)
441NEXT_AFTER_MACRO(4,10)
22a49988 442#endif
11e07fa4
SK		 443NEXT_AFTER_MACRO(8,8)
444NEXT_AFTER_MACRO(8,4)
445NEXT_AFTER_MACRO(4,8)
446NEXT_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 487REM_MACRO(16,16,16)
22a49988 488#ifdef HAVE_GFC_REAL_10
11e07fa4
SK		 489REM_MACRO(16,16,10)
490REM_MACRO(16,10,16)
22a49988 491#endif
11e07fa4
SK		 492REM_MACRO(16,16,8)
493REM_MACRO(16,16,4)
22a49988 494REM_MACRO(16,8,16)
11e07fa4 495REM_MACRO(16,4,16)
22a49988
FXC		 496#endif
497#ifdef HAVE_GFC_REAL_10
22a49988 498REM_MACRO(10,10,10)
11e07fa4
SK		 499REM_MACRO(10,10,8)
500REM_MACRO(10,10,4)
501REM_MACRO(10,8,10)
502REM_MACRO(10,4,10)
22a49988 503#endif
11e07fa4
SK		 504REM_MACRO(8,8,8)
505REM_MACRO(8,8,4)
506REM_MACRO(8,4,8)
507REM_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
867SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
868SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
ede9dea5 869SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
8b198102
FXC		 870SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
871SUPPORTGENERIC(IEEE_SUPPORT_INF)
872SUPPORTGENERIC(IEEE_SUPPORT_IO)
873SUPPORTGENERIC(IEEE_SUPPORT_NAN)
874SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
875SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
8b198102
FXC		 876
877contains
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
1220SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
1221SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
1222#ifdef HAVE_GFC_REAL_10
22a49988 1223SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
8b198102
FXC		 1224#endif
1225#ifdef HAVE_GFC_REAL_16
22a49988 1226SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
8b198102 1227#endif
8b198102 1228SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
8b198102 1229
ede9dea5 1230! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
8b198102
FXC		 1231
1232SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
1233SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
1234#ifdef HAVE_GFC_REAL_10
22a49988 1235SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
8b198102
FXC		 1236#endif
1237#ifdef HAVE_GFC_REAL_16
22a49988 1238SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
8b198102 1239#endif
8b198102 1240SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
8b198102 1241
ede9dea5
SK		 1242SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
1243SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
1244#ifdef HAVE_GFC_REAL_10
1245SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
1246#endif
1247#ifdef HAVE_GFC_REAL_16
1248SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
1249#endif
1250SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
1251
8b198102
FXC		 1252! IEEE_SUPPORT_DIVIDE
1253
1254SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
1255SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
1256#ifdef HAVE_GFC_REAL_10
22a49988 1257SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
8b198102
FXC		 1258#endif
1259#ifdef HAVE_GFC_REAL_16
22a49988 1260SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
8b198102 1261#endif
8b198102 1262SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
8b198102
FXC		 1263
1264! IEEE_SUPPORT_INF
1265
1266SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
1267SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
1268#ifdef HAVE_GFC_REAL_10
22a49988 1269SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
8b198102
FXC		 1270#endif
1271#ifdef HAVE_GFC_REAL_16
22a49988 1272SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
8b198102 1273#endif
8b198102 1274SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
8b198102
FXC		 1275
1276! IEEE_SUPPORT_IO
1277
1278SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
1279SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
1280#ifdef HAVE_GFC_REAL_10
22a49988 1281SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
8b198102
FXC		 1282#endif
1283#ifdef HAVE_GFC_REAL_16
22a49988 1284SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
8b198102 1285#endif
8b198102 1286SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
8b198102
FXC		 1287
1288! IEEE_SUPPORT_NAN
1289
1290SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
1291SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
1292#ifdef HAVE_GFC_REAL_10
22a49988 1293SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
8b198102
FXC		 1294#endif
1295#ifdef HAVE_GFC_REAL_16
22a49988 1296SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
8b198102 1297#endif
8b198102 1298SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
8b198102
FXC		 1299
1300! IEEE_SUPPORT_SQRT
1301
1302SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
1303SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
1304#ifdef HAVE_GFC_REAL_10
22a49988 1305SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
8b198102
FXC		 1306#endif
1307#ifdef HAVE_GFC_REAL_16
22a49988 1308SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
8b198102 1309#endif
8b198102 1310SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
8b198102
FXC		 1311
1312! IEEE_SUPPORT_STANDARD
1313
1314SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
1315SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
1316#ifdef HAVE_GFC_REAL_10
22a49988 1317SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
8b198102
FXC		 1318#endif
1319#ifdef HAVE_GFC_REAL_16
22a49988 1320SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
8b198102 1321#endif
8b198102 1322SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
8b198102 1323
8b198102 1324end module IEEE_ARITHMETIC
GNU Compiler Collection
This page took 0.943133 seconds and 5 git commands to generate.