libgfortran/ieee/ieee_arithmetic.F90

   1 !    Implementation of the IEEE_ARITHMETIC standard intrinsic module
   2 !    Copyright (C) 2013-2023 Free Software Foundation, Inc.
   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, &
  42     IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING, &
  43     IEEE_MODES_TYPE, IEEE_GET_MODES, IEEE_SET_MODES
  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), &
  59     IEEE_NEGATIVE_SUBNORMAL= IEEE_CLASS_TYPE(5), &
  60     IEEE_NEGATIVE_ZERO     = IEEE_CLASS_TYPE(6), &
  61     IEEE_POSITIVE_ZERO     = IEEE_CLASS_TYPE(7), &
  62     IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), &
  63     IEEE_POSITIVE_SUBNORMAL= IEEE_CLASS_TYPE(8), &
  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), &
  77     IEEE_AWAY              = IEEE_ROUND_TYPE(GFC_FPE_AWAY), &
  78     IEEE_OTHER             = IEEE_ROUND_TYPE(0)
  79
  80
  81   ! Equality operators on the derived types
  82   ! Note, the FE overloads .eq. to == and .ne. to /=
  83   interface operator (.eq.)
  84     module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ
  85   end interface
  86   public :: operator(.eq.)
  87
  88   interface operator (.ne.)
  89     module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE
  90   end interface
  91   public :: operator (.ne.)
  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
 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
 113   end interface
 114
 115   interface IEEE_IS_FINITE
 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
 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
 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
 146   end interface
 147
 148   interface IEEE_IS_NAN
 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
 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
 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
 179   end interface
 180
 181   interface IEEE_IS_NEGATIVE
 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
 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
 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
 212   end interface
 213
 214   interface IEEE_IS_NORMAL
 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
 223   end interface
 224   public :: IEEE_IS_NORMAL
 225
 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
 352   ! IEEE_COPY_SIGN
 353
 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
 361   interface
 362 #ifdef HAVE_GFC_REAL_16
 363 COPYSIGN_MACRO(16,16)
 364 #ifdef HAVE_GFC_REAL_10
 365 COPYSIGN_MACRO(16,10)
 366 COPYSIGN_MACRO(10,16)
 367 #endif
 368 COPYSIGN_MACRO(16,8)
 369 COPYSIGN_MACRO(16,4)
 370 COPYSIGN_MACRO(8,16)
 371 COPYSIGN_MACRO(4,16)
 372 #endif
 373 #ifdef HAVE_GFC_REAL_10
 374 COPYSIGN_MACRO(10,10)
 375 COPYSIGN_MACRO(10,8)
 376 COPYSIGN_MACRO(10,4)
 377 COPYSIGN_MACRO(8,10)
 378 COPYSIGN_MACRO(4,10)
 379 #endif
 380 COPYSIGN_MACRO(8,8)
 381 COPYSIGN_MACRO(8,4)
 382 COPYSIGN_MACRO(4,8)
 383 COPYSIGN_MACRO(4,4)
 384   end interface
 385
 386   interface IEEE_COPY_SIGN
 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, &
 392               _gfortran_ieee_copy_sign_10_16, &
 393 #endif
 394               _gfortran_ieee_copy_sign_16_8, &
 395               _gfortran_ieee_copy_sign_16_4, &
 396               _gfortran_ieee_copy_sign_8_16, &
 397               _gfortran_ieee_copy_sign_4_16, &
 398 #endif
 399 #ifdef HAVE_GFC_REAL_10
 400               _gfortran_ieee_copy_sign_10_10, &
 401               _gfortran_ieee_copy_sign_10_8, &
 402               _gfortran_ieee_copy_sign_10_4, &
 403               _gfortran_ieee_copy_sign_8_10, &
 404               _gfortran_ieee_copy_sign_4_10, &
 405 #endif
 406               _gfortran_ieee_copy_sign_8_8, &
 407               _gfortran_ieee_copy_sign_8_4, &
 408               _gfortran_ieee_copy_sign_4_8, &
 409               _gfortran_ieee_copy_sign_4_4
 410   end interface
 411   public :: IEEE_COPY_SIGN
 412
 413   ! IEEE_UNORDERED
 414
 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
 422   interface
 423 #ifdef HAVE_GFC_REAL_16
 424 UNORDERED_MACRO(16,16)
 425 #ifdef HAVE_GFC_REAL_10
 426 UNORDERED_MACRO(16,10)
 427 UNORDERED_MACRO(10,16)
 428 #endif
 429 UNORDERED_MACRO(16,8)
 430 UNORDERED_MACRO(16,4)
 431 UNORDERED_MACRO(8,16)
 432 UNORDERED_MACRO(4,16)
 433 #endif
 434 #ifdef HAVE_GFC_REAL_10
 435 UNORDERED_MACRO(10,10)
 436 UNORDERED_MACRO(10,8)
 437 UNORDERED_MACRO(10,4)
 438 UNORDERED_MACRO(8,10)
 439 UNORDERED_MACRO(4,10)
 440 #endif
 441 UNORDERED_MACRO(8,8)
 442 UNORDERED_MACRO(8,4)
 443 UNORDERED_MACRO(4,8)
 444 UNORDERED_MACRO(4,4)
 445   end interface
 446
 447   interface IEEE_UNORDERED
 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, &
 453               _gfortran_ieee_unordered_10_16, &
 454 #endif
 455               _gfortran_ieee_unordered_16_8, &
 456               _gfortran_ieee_unordered_16_4, &
 457               _gfortran_ieee_unordered_8_16, &
 458               _gfortran_ieee_unordered_4_16, &
 459 #endif
 460 #ifdef HAVE_GFC_REAL_10
 461               _gfortran_ieee_unordered_10_10, &
 462               _gfortran_ieee_unordered_10_8, &
 463               _gfortran_ieee_unordered_10_4, &
 464               _gfortran_ieee_unordered_8_10, &
 465               _gfortran_ieee_unordered_4_10, &
 466 #endif
 467               _gfortran_ieee_unordered_8_8, &
 468               _gfortran_ieee_unordered_8_4, &
 469               _gfortran_ieee_unordered_4_8, &
 470               _gfortran_ieee_unordered_4_4
 471   end interface
 472   public :: IEEE_UNORDERED
 473
 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
 507   ! IEEE_LOGB
 508
 509   interface
 510     elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
 511       real(kind=4), intent(in) :: X
 512     end function
 513     elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
 514       real(kind=8), intent(in) :: X
 515     end function
 516 #ifdef HAVE_GFC_REAL_10
 517     elemental real(kind=10) function _gfortran_ieee_logb_10 (X)
 518       real(kind=10), intent(in) :: X
 519     end function
 520 #endif
 521 #ifdef HAVE_GFC_REAL_16
 522     elemental real(kind=16) function _gfortran_ieee_logb_16 (X)
 523       real(kind=16), intent(in) :: X
 524     end function
 525 #endif
 526   end interface
 527
 528   interface IEEE_LOGB
 529     procedure &
 530 #ifdef HAVE_GFC_REAL_16
 531       _gfortran_ieee_logb_16, &
 532 #endif
 533 #ifdef HAVE_GFC_REAL_10
 534       _gfortran_ieee_logb_10, &
 535 #endif
 536       _gfortran_ieee_logb_8, &
 537       _gfortran_ieee_logb_4
 538   end interface
 539   public :: IEEE_LOGB
 540
 541   ! IEEE_NEXT_AFTER
 542
 543 #define NEXT_AFTER_MACRO(A,B) \
 544   elemental real(kind = A) function \
 545     _gfortran_ieee_next_after_/**/A/**/_/**/B (X,Y) ; \
 546       real(kind = A), intent(in) :: X ; \
 547       real(kind = B), intent(in) :: Y ; \
 548   end function
 549
 550   interface
 551 #ifdef HAVE_GFC_REAL_16
 552 NEXT_AFTER_MACRO(16,16)
 553 #ifdef HAVE_GFC_REAL_10
 554 NEXT_AFTER_MACRO(16,10)
 555 NEXT_AFTER_MACRO(10,16)
 556 #endif
 557 NEXT_AFTER_MACRO(16,8)
 558 NEXT_AFTER_MACRO(16,4)
 559 NEXT_AFTER_MACRO(8,16)
 560 NEXT_AFTER_MACRO(4,16)
 561 #endif
 562 #ifdef HAVE_GFC_REAL_10
 563 NEXT_AFTER_MACRO(10,10)
 564 NEXT_AFTER_MACRO(10,8)
 565 NEXT_AFTER_MACRO(10,4)
 566 NEXT_AFTER_MACRO(8,10)
 567 NEXT_AFTER_MACRO(4,10)
 568 #endif
 569 NEXT_AFTER_MACRO(8,8)
 570 NEXT_AFTER_MACRO(8,4)
 571 NEXT_AFTER_MACRO(4,8)
 572 NEXT_AFTER_MACRO(4,4)
 573   end interface
 574
 575   interface IEEE_NEXT_AFTER
 576     procedure &
 577 #ifdef HAVE_GFC_REAL_16
 578       _gfortran_ieee_next_after_16_16, &
 579 #ifdef HAVE_GFC_REAL_10
 580       _gfortran_ieee_next_after_16_10, &
 581       _gfortran_ieee_next_after_10_16, &
 582 #endif
 583       _gfortran_ieee_next_after_16_8, &
 584       _gfortran_ieee_next_after_16_4, &
 585       _gfortran_ieee_next_after_8_16, &
 586       _gfortran_ieee_next_after_4_16, &
 587 #endif
 588 #ifdef HAVE_GFC_REAL_10
 589       _gfortran_ieee_next_after_10_10, &
 590       _gfortran_ieee_next_after_10_8, &
 591       _gfortran_ieee_next_after_10_4, &
 592       _gfortran_ieee_next_after_8_10, &
 593       _gfortran_ieee_next_after_4_10, &
 594 #endif
 595       _gfortran_ieee_next_after_8_8, &
 596       _gfortran_ieee_next_after_8_4, &
 597       _gfortran_ieee_next_after_4_8, &
 598       _gfortran_ieee_next_after_4_4
 599   end interface
 600   public :: IEEE_NEXT_AFTER
 601
 602   ! IEEE_REM
 603
 604 #define REM_MACRO(RES,A,B) \
 605   elemental real(kind = RES) function \
 606     _gfortran_ieee_rem_/**/A/**/_/**/B (X,Y) ; \
 607       real(kind = A), intent(in) :: X ; \
 608       real(kind = B), intent(in) :: Y ; \
 609   end function
 610
 611   interface
 612 #ifdef HAVE_GFC_REAL_16
 613 REM_MACRO(16,16,16)
 614 #ifdef HAVE_GFC_REAL_10
 615 REM_MACRO(16,16,10)
 616 REM_MACRO(16,10,16)
 617 #endif
 618 REM_MACRO(16,16,8)
 619 REM_MACRO(16,16,4)
 620 REM_MACRO(16,8,16)
 621 REM_MACRO(16,4,16)
 622 #endif
 623 #ifdef HAVE_GFC_REAL_10
 624 REM_MACRO(10,10,10)
 625 REM_MACRO(10,10,8)
 626 REM_MACRO(10,10,4)
 627 REM_MACRO(10,8,10)
 628 REM_MACRO(10,4,10)
 629 #endif
 630 REM_MACRO(8,8,8)
 631 REM_MACRO(8,8,4)
 632 REM_MACRO(8,4,8)
 633 REM_MACRO(4,4,4)
 634   end interface
 635
 636   interface IEEE_REM
 637     procedure &
 638 #ifdef HAVE_GFC_REAL_16
 639       _gfortran_ieee_rem_16_16, &
 640 #ifdef HAVE_GFC_REAL_10
 641       _gfortran_ieee_rem_16_10, &
 642       _gfortran_ieee_rem_10_16, &
 643 #endif
 644       _gfortran_ieee_rem_16_8, &
 645       _gfortran_ieee_rem_16_4, &
 646       _gfortran_ieee_rem_8_16, &
 647       _gfortran_ieee_rem_4_16, &
 648 #endif
 649 #ifdef HAVE_GFC_REAL_10
 650       _gfortran_ieee_rem_10_10, &
 651       _gfortran_ieee_rem_10_8, &
 652       _gfortran_ieee_rem_10_4, &
 653       _gfortran_ieee_rem_8_10, &
 654       _gfortran_ieee_rem_4_10, &
 655 #endif
 656       _gfortran_ieee_rem_8_8, &
 657       _gfortran_ieee_rem_8_4, &
 658       _gfortran_ieee_rem_4_8, &
 659       _gfortran_ieee_rem_4_4
 660   end interface
 661   public :: IEEE_REM
 662
 663   ! IEEE_RINT
 664
 665   interface
 666     elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
 667       real(kind=4), intent(in) :: X
 668     end function
 669     elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
 670       real(kind=8), intent(in) :: X
 671     end function
 672 #ifdef HAVE_GFC_REAL_10
 673     elemental real(kind=10) function _gfortran_ieee_rint_10 (X)
 674       real(kind=10), intent(in) :: X
 675     end function
 676 #endif
 677 #ifdef HAVE_GFC_REAL_16
 678     elemental real(kind=16) function _gfortran_ieee_rint_16 (X)
 679       real(kind=16), intent(in) :: X
 680     end function
 681 #endif
 682   end interface
 683
 684   interface IEEE_RINT
 685     procedure &
 686 #ifdef HAVE_GFC_REAL_16
 687       _gfortran_ieee_rint_16, &
 688 #endif
 689 #ifdef HAVE_GFC_REAL_10
 690       _gfortran_ieee_rint_10, &
 691 #endif
 692       _gfortran_ieee_rint_8, _gfortran_ieee_rint_4
 693   end interface
 694   public :: IEEE_RINT
 695
 696   ! IEEE_SCALB
 697
 698   interface
 699 #ifdef HAVE_GFC_INTEGER_16
 700 #ifdef HAVE_GFC_REAL_16
 701     elemental real(kind=16) function _gfortran_ieee_scalb_16_16 (X, I)
 702       real(kind=16), intent(in) :: X
 703       integer(kind=16), intent(in) :: I
 704     end function
 705 #endif
 706 #ifdef HAVE_GFC_REAL_10
 707     elemental real(kind=10) function _gfortran_ieee_scalb_10_16 (X, I)
 708       real(kind=10), intent(in) :: X
 709       integer(kind=16), intent(in) :: I
 710     end function
 711 #endif
 712     elemental real(kind=8) function _gfortran_ieee_scalb_8_16 (X, I)
 713       real(kind=8), intent(in) :: X
 714       integer(kind=16), intent(in) :: I
 715     end function
 716     elemental real(kind=4) function _gfortran_ieee_scalb_4_16 (X, I)
 717       real(kind=4), intent(in) :: X
 718       integer(kind=16), intent(in) :: I
 719     end function
 720 #endif
 721
 722 #ifdef HAVE_GFC_INTEGER_8
 723 #ifdef HAVE_GFC_REAL_16
 724     elemental real(kind=16) function _gfortran_ieee_scalb_16_8 (X, I)
 725       real(kind=16), intent(in) :: X
 726       integer(kind=8), intent(in) :: I
 727     end function
 728 #endif
 729 #ifdef HAVE_GFC_REAL_10
 730     elemental real(kind=10) function _gfortran_ieee_scalb_10_8 (X, I)
 731       real(kind=10), intent(in) :: X
 732       integer(kind=8), intent(in) :: I
 733     end function
 734 #endif
 735     elemental real(kind=8) function _gfortran_ieee_scalb_8_8 (X, I)
 736       real(kind=8), intent(in) :: X
 737       integer(kind=8), intent(in) :: I
 738     end function
 739     elemental real(kind=4) function _gfortran_ieee_scalb_4_8 (X, I)
 740       real(kind=4), intent(in) :: X
 741       integer(kind=8), intent(in) :: I
 742     end function
 743 #endif
 744
 745 #ifdef HAVE_GFC_INTEGER_2
 746 #ifdef HAVE_GFC_REAL_16
 747     elemental real(kind=16) function _gfortran_ieee_scalb_16_2 (X, I)
 748       real(kind=16), intent(in) :: X
 749       integer(kind=2), intent(in) :: I
 750     end function
 751 #endif
 752 #ifdef HAVE_GFC_REAL_10
 753     elemental real(kind=10) function _gfortran_ieee_scalb_10_2 (X, I)
 754       real(kind=10), intent(in) :: X
 755       integer(kind=2), intent(in) :: I
 756     end function
 757 #endif
 758     elemental real(kind=8) function _gfortran_ieee_scalb_8_2 (X, I)
 759       real(kind=8), intent(in) :: X
 760       integer(kind=2), intent(in) :: I
 761     end function
 762     elemental real(kind=4) function _gfortran_ieee_scalb_4_2 (X, I)
 763       real(kind=4), intent(in) :: X
 764       integer(kind=2), intent(in) :: I
 765     end function
 766 #endif
 767
 768 #ifdef HAVE_GFC_INTEGER_1
 769 #ifdef HAVE_GFC_REAL_16
 770     elemental real(kind=16) function _gfortran_ieee_scalb_16_1 (X, I)
 771       real(kind=16), intent(in) :: X
 772       integer(kind=1), intent(in) :: I
 773     end function
 774 #endif
 775 #ifdef HAVE_GFC_REAL_10
 776     elemental real(kind=10) function _gfortran_ieee_scalb_10_1 (X, I)
 777       real(kind=10), intent(in) :: X
 778       integer(kind=1), intent(in) :: I
 779     end function
 780 #endif
 781     elemental real(kind=8) function _gfortran_ieee_scalb_8_1 (X, I)
 782       real(kind=8), intent(in) :: X
 783       integer(kind=1), intent(in) :: I
 784     end function
 785     elemental real(kind=4) function _gfortran_ieee_scalb_4_1 (X, I)
 786       real(kind=4), intent(in) :: X
 787       integer(kind=1), intent(in) :: I
 788     end function
 789 #endif
 790
 791 #ifdef HAVE_GFC_REAL_16
 792     elemental real(kind=16) function _gfortran_ieee_scalb_16_4 (X, I)
 793       real(kind=16), intent(in) :: X
 794       integer, intent(in) :: I
 795     end function
 796 #endif
 797 #ifdef HAVE_GFC_REAL_10
 798     elemental real(kind=10) function _gfortran_ieee_scalb_10_4 (X, I)
 799       real(kind=10), intent(in) :: X
 800       integer, intent(in) :: I
 801     end function
 802 #endif
 803     elemental real(kind=8) function _gfortran_ieee_scalb_8_4 (X, I)
 804       real(kind=8), intent(in) :: X
 805       integer, intent(in) :: I
 806     end function
 807     elemental real(kind=4) function _gfortran_ieee_scalb_4_4 (X, I)
 808       real(kind=4), intent(in) :: X
 809       integer, intent(in) :: I
 810     end function
 811   end interface
 812
 813   interface IEEE_SCALB
 814     procedure &
 815 #ifdef HAVE_GFC_INTEGER_16
 816 #ifdef HAVE_GFC_REAL_16
 817     _gfortran_ieee_scalb_16_16, &
 818 #endif
 819 #ifdef HAVE_GFC_REAL_10
 820     _gfortran_ieee_scalb_10_16, &
 821 #endif
 822     _gfortran_ieee_scalb_8_16, &
 823     _gfortran_ieee_scalb_4_16, &
 824 #endif
 825 #ifdef HAVE_GFC_INTEGER_8
 826 #ifdef HAVE_GFC_REAL_16
 827     _gfortran_ieee_scalb_16_8, &
 828 #endif
 829 #ifdef HAVE_GFC_REAL_10
 830     _gfortran_ieee_scalb_10_8, &
 831 #endif
 832     _gfortran_ieee_scalb_8_8, &
 833     _gfortran_ieee_scalb_4_8, &
 834 #endif
 835 #ifdef HAVE_GFC_INTEGER_2
 836 #ifdef HAVE_GFC_REAL_16
 837     _gfortran_ieee_scalb_16_2, &
 838 #endif
 839 #ifdef HAVE_GFC_REAL_10
 840     _gfortran_ieee_scalb_10_2, &
 841 #endif
 842     _gfortran_ieee_scalb_8_2, &
 843     _gfortran_ieee_scalb_4_2, &
 844 #endif
 845 #ifdef HAVE_GFC_INTEGER_1
 846 #ifdef HAVE_GFC_REAL_16
 847     _gfortran_ieee_scalb_16_1, &
 848 #endif
 849 #ifdef HAVE_GFC_REAL_10
 850     _gfortran_ieee_scalb_10_1, &
 851 #endif
 852     _gfortran_ieee_scalb_8_1, &
 853     _gfortran_ieee_scalb_4_1, &
 854 #endif
 855 #ifdef HAVE_GFC_REAL_16
 856     _gfortran_ieee_scalb_16_4, &
 857 #endif
 858 #ifdef HAVE_GFC_REAL_10
 859     _gfortran_ieee_scalb_10_4, &
 860 #endif
 861       _gfortran_ieee_scalb_8_4, &
 862       _gfortran_ieee_scalb_4_4
 863   end interface
 864   public :: IEEE_SCALB
 865
 866   ! IEEE_SIGNBIT
 867
 868   interface
 869     elemental logical function _gfortran_ieee_signbit_4 (X)
 870       real(kind=4), intent(in) :: X
 871     end function
 872     elemental logical function _gfortran_ieee_signbit_8 (X)
 873       real(kind=8), intent(in) :: X
 874     end function
 875 #ifdef HAVE_GFC_REAL_10
 876     elemental logical function _gfortran_ieee_signbit_10 (X)
 877       real(kind=10), intent(in) :: X
 878     end function
 879 #endif
 880 #ifdef HAVE_GFC_REAL_16
 881     elemental logical function _gfortran_ieee_signbit_16 (X)
 882       real(kind=16), intent(in) :: X
 883     end function
 884 #endif
 885   end interface
 886
 887   interface IEEE_SIGNBIT
 888     procedure &
 889 #ifdef HAVE_GFC_REAL_16
 890       _gfortran_ieee_signbit_16, &
 891 #endif
 892 #ifdef HAVE_GFC_REAL_10
 893       _gfortran_ieee_signbit_10, &
 894 #endif
 895       _gfortran_ieee_signbit_8, _gfortran_ieee_signbit_4
 896   end interface
 897   public :: IEEE_SIGNBIT
 898
 899   ! IEEE_VALUE
 900
 901   interface IEEE_VALUE
 902     module procedure &
 903 #ifdef HAVE_GFC_REAL_16
 904       IEEE_VALUE_16, &
 905 #endif
 906 #ifdef HAVE_GFC_REAL_10
 907       IEEE_VALUE_10, &
 908 #endif
 909       IEEE_VALUE_8, IEEE_VALUE_4
 910   end interface
 911   public :: IEEE_VALUE
 912
 913   ! IEEE_CLASS
 914
 915   interface IEEE_CLASS
 916     module procedure &
 917 #ifdef HAVE_GFC_REAL_16
 918       IEEE_CLASS_16, &
 919 #endif
 920 #ifdef HAVE_GFC_REAL_10
 921       IEEE_CLASS_10, &
 922 #endif
 923       IEEE_CLASS_8, IEEE_CLASS_4
 924   end interface
 925   public :: IEEE_CLASS
 926
 927   ! Public declarations for contained procedures
 928   public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
 929   public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
 930   public :: IEEE_SELECTED_REAL_KIND
 931
 932   ! IEEE_SUPPORT_ROUNDING
 933
 934   interface IEEE_SUPPORT_ROUNDING
 935     module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
 936 #ifdef HAVE_GFC_REAL_10
 937                      IEEE_SUPPORT_ROUNDING_10, &
 938 #endif
 939 #ifdef HAVE_GFC_REAL_16
 940                      IEEE_SUPPORT_ROUNDING_16, &
 941 #endif
 942                      IEEE_SUPPORT_ROUNDING_NOARG
 943   end interface
 944   public :: IEEE_SUPPORT_ROUNDING
 945
 946   ! Interface to the FPU-specific function
 947   interface
 948     pure integer function support_rounding_helper(flag) &
 949         bind(c, name="_gfortrani_support_fpu_rounding_mode")
 950       integer, intent(in), value :: flag
 951     end function
 952   end interface
 953
 954   ! IEEE_SUPPORT_UNDERFLOW_CONTROL
 955
 956   interface IEEE_SUPPORT_UNDERFLOW_CONTROL
 957     module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, &
 958                      IEEE_SUPPORT_UNDERFLOW_CONTROL_8, &
 959 #ifdef HAVE_GFC_REAL_10
 960                      IEEE_SUPPORT_UNDERFLOW_CONTROL_10, &
 961 #endif
 962 #ifdef HAVE_GFC_REAL_16
 963                      IEEE_SUPPORT_UNDERFLOW_CONTROL_16, &
 964 #endif
 965                      IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG
 966   end interface
 967   public :: IEEE_SUPPORT_UNDERFLOW_CONTROL
 968
 969   ! Interface to the FPU-specific function
 970   interface
 971     pure integer function support_underflow_control_helper(kind) &
 972         bind(c, name="_gfortrani_support_fpu_underflow_control")
 973       integer, intent(in), value :: kind
 974     end function
 975   end interface
 976
 977 ! IEEE_SUPPORT_* generic functions
 978
 979 #if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
 980 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
 981 #elif defined(HAVE_GFC_REAL_10)
 982 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
 983 #elif defined(HAVE_GFC_REAL_16)
 984 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
 985 #else
 986 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
 987 #endif
 988
 989 #define SUPPORTGENERIC(NAME) \
 990   interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
 991   public :: NAME
 992
 993 SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
 994 SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
 995 SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
 996 SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
 997 SUPPORTGENERIC(IEEE_SUPPORT_INF)
 998 SUPPORTGENERIC(IEEE_SUPPORT_IO)
 999 SUPPORTGENERIC(IEEE_SUPPORT_NAN)
1000 SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
1001 SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
1002
1003 contains
1004
1005   ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
1006   elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
1007     implicit none
1008     type(IEEE_CLASS_TYPE), intent(in) :: X, Y
1009     res = (X%hidden == Y%hidden)
1010   end function
1011
1012   elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
1013     implicit none
1014     type(IEEE_CLASS_TYPE), intent(in) :: X, Y
1015     res = (X%hidden /= Y%hidden)
1016   end function
1017
1018   elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
1019     implicit none
1020     type(IEEE_ROUND_TYPE), intent(in) :: X, Y
1021     res = (X%hidden == Y%hidden)
1022   end function
1023
1024   elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
1025     implicit none
1026     type(IEEE_ROUND_TYPE), intent(in) :: X, Y
1027     res = (X%hidden /= Y%hidden)
1028   end function
1029
1030
1031   ! IEEE_SELECTED_REAL_KIND
1032
1033   integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
1034     implicit none
1035     integer, intent(in), optional :: P, R, RADIX
1036
1037     ! Currently, if IEEE is supported and this module is built, it means
1038     ! all our floating-point types conform to IEEE. Hence, we simply call
1039     ! SELECTED_REAL_KIND.
1040
1041     res = SELECTED_REAL_KIND (P, R, RADIX)
1042
1043   end function
1044
1045
1046   ! IEEE_CLASS
1047
1048   elemental function IEEE_CLASS_4 (X) result(res)
1049     implicit none
1050     real(kind=4), intent(in) :: X
1051     type(IEEE_CLASS_TYPE) :: res
1052
1053     interface
1054       pure integer function _gfortrani_ieee_class_helper_4(val)
1055         real(kind=4), intent(in) :: val
1056       end function
1057     end interface
1058
1059     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
1060   end function
1061
1062   elemental function IEEE_CLASS_8 (X) result(res)
1063     implicit none
1064     real(kind=8), intent(in) :: X
1065     type(IEEE_CLASS_TYPE) :: res
1066
1067     interface
1068       pure integer function _gfortrani_ieee_class_helper_8(val)
1069         real(kind=8), intent(in) :: val
1070       end function
1071     end interface
1072
1073     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
1074   end function
1075
1076 #ifdef HAVE_GFC_REAL_10
1077   elemental function IEEE_CLASS_10 (X) result(res)
1078     implicit none
1079     real(kind=10), intent(in) :: X
1080     type(IEEE_CLASS_TYPE) :: res
1081
1082     interface
1083       pure integer function _gfortrani_ieee_class_helper_10(val)
1084         real(kind=10), intent(in) :: val
1085       end function
1086     end interface
1087
1088     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_10(X))
1089   end function
1090 #endif
1091
1092 #ifdef HAVE_GFC_REAL_16
1093   elemental function IEEE_CLASS_16 (X) result(res)
1094     implicit none
1095     real(kind=16), intent(in) :: X
1096     type(IEEE_CLASS_TYPE) :: res
1097
1098     interface
1099       pure integer function _gfortrani_ieee_class_helper_16(val)
1100         real(kind=16), intent(in) :: val
1101       end function
1102     end interface
1103
1104     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_16(X))
1105   end function
1106 #endif
1107
1108
1109   ! IEEE_VALUE
1110
1111   elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
1112     real(kind=4), intent(in) :: X
1113     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1114
1115     interface
1116       pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
1117         use ISO_C_BINDING, only: C_INT
1118         integer(kind=C_INT), value :: x
1119       end function
1120     end interface
1121
1122     res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
1123   end function
1124
1125   elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
1126     real(kind=8), intent(in) :: X
1127     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1128
1129     interface
1130       pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
1131         use ISO_C_BINDING, only: C_INT
1132         integer(kind=C_INT), value :: x
1133       end function
1134     end interface
1135
1136     res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
1137   end function
1138
1139 #ifdef HAVE_GFC_REAL_10
1140   elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
1141     real(kind=10), intent(in) :: X
1142     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1143
1144     interface
1145       pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
1146         use ISO_C_BINDING, only: C_INT
1147         integer(kind=C_INT), value :: x
1148       end function
1149     end interface
1150
1151     res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
1152   end function
1153
1154 #endif
1155
1156 #ifdef HAVE_GFC_REAL_16
1157   elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
1158     real(kind=16), intent(in) :: X
1159     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1160
1161     interface
1162       pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
1163         use ISO_C_BINDING, only: C_INT
1164         integer(kind=C_INT), value :: x
1165       end function
1166     end interface
1167
1168     res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
1169   end function
1170 #endif
1171
1172
1173   ! IEEE_GET_ROUNDING_MODE
1174
1175   subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE, RADIX)
1176     implicit none
1177     type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
1178     integer, intent(in), optional :: RADIX
1179
1180     interface
1181       integer function helper() &
1182         bind(c, name="_gfortrani_get_fpu_rounding_mode")
1183       end function
1184     end interface
1185
1186     ROUND_VALUE = IEEE_ROUND_TYPE(helper())
1187   end subroutine
1188
1189
1190   ! IEEE_SET_ROUNDING_MODE
1191
1192   subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE, RADIX)
1193     implicit none
1194     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1195     integer, intent(in), optional :: RADIX
1196
1197     interface
1198       subroutine helper(val) &
1199           bind(c, name="_gfortrani_set_fpu_rounding_mode")
1200         integer, value :: val
1201       end subroutine
1202     end interface
1203
1204     ! We do not support RADIX = 10, and such calls should not
1205     ! modify the binary rounding mode.
1206     if (present(RADIX)) then
1207       if (RADIX == 10) return
1208     end if
1209
1210     call helper(ROUND_VALUE%hidden)
1211   end subroutine
1212
1213
1214   ! IEEE_GET_UNDERFLOW_MODE
1215
1216   subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
1217     implicit none
1218     logical, intent(out) :: GRADUAL
1219
1220     interface
1221       integer function helper() &
1222         bind(c, name="_gfortrani_get_fpu_underflow_mode")
1223       end function
1224     end interface
1225
1226     GRADUAL = (helper() /= 0)
1227   end subroutine
1228
1229
1230   ! IEEE_SET_UNDERFLOW_MODE
1231
1232   subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
1233     implicit none
1234     logical, intent(in) :: GRADUAL
1235
1236     interface
1237       subroutine helper(val) &
1238           bind(c, name="_gfortrani_set_fpu_underflow_mode")
1239         integer, value :: val
1240       end subroutine
1241     end interface
1242
1243     call helper(merge(1, 0, GRADUAL))
1244   end subroutine
1245
1246 ! IEEE_SUPPORT_ROUNDING
1247
1248   pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
1249     implicit none
1250     real(kind=4), intent(in) :: X
1251     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1252     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1253   end function
1254
1255   pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
1256     implicit none
1257     real(kind=8), intent(in) :: X
1258     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1259     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1260   end function
1261
1262 #ifdef HAVE_GFC_REAL_10
1263   pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
1264     implicit none
1265     real(kind=10), intent(in) :: X
1266     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1267     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1268   end function
1269 #endif
1270
1271 #ifdef HAVE_GFC_REAL_16
1272   pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
1273     implicit none
1274     real(kind=16), intent(in) :: X
1275     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1276     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1277   end function
1278 #endif
1279
1280   pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
1281     implicit none
1282     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1283     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1284   end function
1285
1286 ! IEEE_SUPPORT_UNDERFLOW_CONTROL
1287
1288   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res)
1289     implicit none
1290     real(kind=4), intent(in) :: X
1291     res = (support_underflow_control_helper(4) /= 0)
1292   end function
1293
1294   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res)
1295     implicit none
1296     real(kind=8), intent(in) :: X
1297     res = (support_underflow_control_helper(8) /= 0)
1298   end function
1299
1300 #ifdef HAVE_GFC_REAL_10
1301   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res)
1302     implicit none
1303     real(kind=10), intent(in) :: X
1304     res = (support_underflow_control_helper(10) /= 0)
1305   end function
1306 #endif
1307
1308 #ifdef HAVE_GFC_REAL_16
1309   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res)
1310     implicit none
1311     real(kind=16), intent(in) :: X
1312     res = (support_underflow_control_helper(16) /= 0)
1313   end function
1314 #endif
1315
1316   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
1317     implicit none
1318     res = (support_underflow_control_helper(4) /= 0 &
1319            .and. support_underflow_control_helper(8) /= 0 &
1320 #ifdef HAVE_GFC_REAL_10
1321            .and. support_underflow_control_helper(10) /= 0 &
1322 #endif
1323 #ifdef HAVE_GFC_REAL_16
1324            .and. support_underflow_control_helper(16) /= 0 &
1325 #endif
1326           )
1327   end function
1328
1329 ! IEEE_SUPPORT_* functions
1330
1331 #define SUPPORTMACRO(NAME, INTKIND, VALUE) \
1332   pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
1333     implicit none                                            ; \
1334     real(INTKIND), intent(in) :: X(..)                       ; \
1335     res = VALUE                                              ; \
1336   end function
1337
1338 #define SUPPORTMACRO_NOARG(NAME, VALUE) \
1339   pure logical function NAME/**/_NOARG () result(res) ; \
1340     implicit none                                     ; \
1341     res = VALUE                                       ; \
1342   end function
1343
1344 ! IEEE_SUPPORT_DATATYPE
1345
1346 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
1347 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
1348 #ifdef HAVE_GFC_REAL_10
1349 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
1350 #endif
1351 #ifdef HAVE_GFC_REAL_16
1352 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
1353 #endif
1354 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
1355
1356 ! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
1357
1358 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
1359 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
1360 #ifdef HAVE_GFC_REAL_10
1361 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
1362 #endif
1363 #ifdef HAVE_GFC_REAL_16
1364 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
1365 #endif
1366 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
1367
1368 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
1369 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
1370 #ifdef HAVE_GFC_REAL_10
1371 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
1372 #endif
1373 #ifdef HAVE_GFC_REAL_16
1374 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
1375 #endif
1376 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
1377
1378 ! IEEE_SUPPORT_DIVIDE
1379
1380 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
1381 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
1382 #ifdef HAVE_GFC_REAL_10
1383 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
1384 #endif
1385 #ifdef HAVE_GFC_REAL_16
1386 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
1387 #endif
1388 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
1389
1390 ! IEEE_SUPPORT_INF
1391
1392 SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
1393 SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
1394 #ifdef HAVE_GFC_REAL_10
1395 SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
1396 #endif
1397 #ifdef HAVE_GFC_REAL_16
1398 SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
1399 #endif
1400 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
1401
1402 ! IEEE_SUPPORT_IO
1403
1404 SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
1405 SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
1406 #ifdef HAVE_GFC_REAL_10
1407 SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
1408 #endif
1409 #ifdef HAVE_GFC_REAL_16
1410 SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
1411 #endif
1412 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
1413
1414 ! IEEE_SUPPORT_NAN
1415
1416 SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
1417 SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
1418 #ifdef HAVE_GFC_REAL_10
1419 SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
1420 #endif
1421 #ifdef HAVE_GFC_REAL_16
1422 SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
1423 #endif
1424 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
1425
1426 ! IEEE_SUPPORT_SQRT
1427
1428 SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
1429 SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
1430 #ifdef HAVE_GFC_REAL_10
1431 SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
1432 #endif
1433 #ifdef HAVE_GFC_REAL_16
1434 SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
1435 #endif
1436 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
1437
1438 ! IEEE_SUPPORT_STANDARD
1439
1440 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
1441 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
1442 #ifdef HAVE_GFC_REAL_10
1443 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
1444 #endif
1445 #ifdef HAVE_GFC_REAL_16
1446 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
1447 #endif
1448 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
1449
1450 end module IEEE_ARITHMETIC