libgfortran/ieee/ieee_arithmetic.F90

   1 !    Implementation of the IEEE_ARITHMETIC standard intrinsic module
   2 !    Copyright (C) 2013-2024 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_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
 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
 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
 595   end interface
 596
 597   interface IEEE_LOGB
 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
 607   end interface
 608   public :: IEEE_LOGB
 609
 610   ! IEEE_NEXT_AFTER
 611
 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
 619   interface
 620 #ifdef HAVE_GFC_REAL_16
 621 NEXT_AFTER_MACRO(16,16)
 622 #ifdef HAVE_GFC_REAL_10
 623 NEXT_AFTER_MACRO(16,10)
 624 NEXT_AFTER_MACRO(10,16)
 625 #endif
 626 NEXT_AFTER_MACRO(16,8)
 627 NEXT_AFTER_MACRO(16,4)
 628 NEXT_AFTER_MACRO(8,16)
 629 NEXT_AFTER_MACRO(4,16)
 630 #endif
 631 #ifdef HAVE_GFC_REAL_10
 632 NEXT_AFTER_MACRO(10,10)
 633 NEXT_AFTER_MACRO(10,8)
 634 NEXT_AFTER_MACRO(10,4)
 635 NEXT_AFTER_MACRO(8,10)
 636 NEXT_AFTER_MACRO(4,10)
 637 #endif
 638 NEXT_AFTER_MACRO(8,8)
 639 NEXT_AFTER_MACRO(8,4)
 640 NEXT_AFTER_MACRO(4,8)
 641 NEXT_AFTER_MACRO(4,4)
 642   end interface
 643
 644   interface IEEE_NEXT_AFTER
 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, &
 650       _gfortran_ieee_next_after_10_16, &
 651 #endif
 652       _gfortran_ieee_next_after_16_8, &
 653       _gfortran_ieee_next_after_16_4, &
 654       _gfortran_ieee_next_after_8_16, &
 655       _gfortran_ieee_next_after_4_16, &
 656 #endif
 657 #ifdef HAVE_GFC_REAL_10
 658       _gfortran_ieee_next_after_10_10, &
 659       _gfortran_ieee_next_after_10_8, &
 660       _gfortran_ieee_next_after_10_4, &
 661       _gfortran_ieee_next_after_8_10, &
 662       _gfortran_ieee_next_after_4_10, &
 663 #endif
 664       _gfortran_ieee_next_after_8_8, &
 665       _gfortran_ieee_next_after_8_4, &
 666       _gfortran_ieee_next_after_4_8, &
 667       _gfortran_ieee_next_after_4_4
 668   end interface
 669   public :: IEEE_NEXT_AFTER
 670
 671   ! IEEE_REM
 672
 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
 680   interface
 681 #ifdef HAVE_GFC_REAL_16
 682 REM_MACRO(16,16,16)
 683 #ifdef HAVE_GFC_REAL_10
 684 REM_MACRO(16,16,10)
 685 REM_MACRO(16,10,16)
 686 #endif
 687 REM_MACRO(16,16,8)
 688 REM_MACRO(16,16,4)
 689 REM_MACRO(16,8,16)
 690 REM_MACRO(16,4,16)
 691 #endif
 692 #ifdef HAVE_GFC_REAL_10
 693 REM_MACRO(10,10,10)
 694 REM_MACRO(10,10,8)
 695 REM_MACRO(10,10,4)
 696 REM_MACRO(10,8,10)
 697 REM_MACRO(10,4,10)
 698 #endif
 699 REM_MACRO(8,8,8)
 700 REM_MACRO(8,8,4)
 701 REM_MACRO(8,4,8)
 702 REM_MACRO(4,4,4)
 703   end interface
 704
 705   interface IEEE_REM
 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, &
 711       _gfortran_ieee_rem_10_16, &
 712 #endif
 713       _gfortran_ieee_rem_16_8, &
 714       _gfortran_ieee_rem_16_4, &
 715       _gfortran_ieee_rem_8_16, &
 716       _gfortran_ieee_rem_4_16, &
 717 #endif
 718 #ifdef HAVE_GFC_REAL_10
 719       _gfortran_ieee_rem_10_10, &
 720       _gfortran_ieee_rem_10_8, &
 721       _gfortran_ieee_rem_10_4, &
 722       _gfortran_ieee_rem_8_10, &
 723       _gfortran_ieee_rem_4_10, &
 724 #endif
 725       _gfortran_ieee_rem_8_8, &
 726       _gfortran_ieee_rem_8_4, &
 727       _gfortran_ieee_rem_4_8, &
 728       _gfortran_ieee_rem_4_4
 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
 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
 751   end interface
 752
 753   interface IEEE_RINT
 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
 762   end interface
 763   public :: IEEE_RINT
 764
 765   ! IEEE_SCALB
 766
 767   interface
 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)
 786       real(kind=4), intent(in) :: X
 787       integer(kind=16), intent(in) :: I
 788     end function
 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)
 805       real(kind=8), intent(in) :: X
 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
 819     end function
 820 #endif
 821 #ifdef HAVE_GFC_REAL_10
 822     elemental real(kind=10) function _gfortran_ieee_scalb_10_2 (X, I)
 823       real(kind=10), intent(in) :: X
 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
 842     end function
 843 #endif
 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
 860 #ifdef HAVE_GFC_REAL_16
 861     elemental real(kind=16) function _gfortran_ieee_scalb_16_4 (X, I)
 862       real(kind=16), intent(in) :: X
 863       integer, intent(in) :: I
 864     end function
 865 #endif
 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
 880   end interface
 881
 882   interface IEEE_SCALB
 883     procedure &
 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
 924 #ifdef HAVE_GFC_REAL_16
 925     _gfortran_ieee_scalb_16_4, &
 926 #endif
 927 #ifdef HAVE_GFC_REAL_10
 928     _gfortran_ieee_scalb_10_4, &
 929 #endif
 930       _gfortran_ieee_scalb_8_4, &
 931       _gfortran_ieee_scalb_4_4
 932   end interface
 933   public :: IEEE_SCALB
 934
 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
 968   ! IEEE_VALUE
 969
 970   interface IEEE_VALUE
 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
 979   end interface
 980   public :: IEEE_VALUE
 981
 982   ! IEEE_CLASS
 983
 984   interface IEEE_CLASS
 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
 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
1014
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
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
1037
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
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
1062 SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
1063 SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
1064 SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
1065 SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
1066 SUPPORTGENERIC(IEEE_SUPPORT_INF)
1067 SUPPORTGENERIC(IEEE_SUPPORT_IO)
1068 SUPPORTGENERIC(IEEE_SUPPORT_NAN)
1069 SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
1070 SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
1071
1072 contains
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
1099
1100   ! IEEE_SELECTED_REAL_KIND
1101
1102   integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
1103     implicit none
1104     integer, intent(in), optional :: P, R, RADIX
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
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
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
1178   ! IEEE_VALUE
1179
1180   elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
1181     real(kind=4), intent(in) :: X
1182     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
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)
1192   end function
1193
1194   elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
1195     real(kind=8), intent(in) :: X
1196     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
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)
1206   end function
1207
1208 #ifdef HAVE_GFC_REAL_10
1209   elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
1210     real(kind=10), intent(in) :: X
1211     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
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)
1221   end function
1222
1223 #endif
1224
1225 #ifdef HAVE_GFC_REAL_16
1226   elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
1227     real(kind=16), intent(in) :: X
1228     type(IEEE_CLASS_TYPE), intent(in) :: CLASS
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)
1238   end function
1239 #endif
1240
1241
1242   ! IEEE_GET_ROUNDING_MODE
1243
1244   subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE, RADIX)
1245     implicit none
1246     type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
1247     integer, intent(in), optional :: RADIX
1248
1249     interface
1250       integer function helper() &
1251         bind(c, name="_gfortrani_get_fpu_rounding_mode")
1252       end function
1253     end interface
1254
1255     ROUND_VALUE = IEEE_ROUND_TYPE(helper())
1256   end subroutine
1257
1258
1259   ! IEEE_SET_ROUNDING_MODE
1260
1261   subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE, RADIX)
1262     implicit none
1263     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
1264     integer, intent(in), optional :: RADIX
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
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
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
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)
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
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))
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
1336     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
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
1345     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
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
1352     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
1353   end function
1354
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
1373     res = (support_underflow_control_helper(10) /= 0)
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
1381     res = (support_underflow_control_helper(16) /= 0)
1382   end function
1383 #endif
1384
1385   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
1386     implicit none
1387     res = (support_underflow_control_helper(4) /= 0 &
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 &
1394 #endif
1395           )
1396   end function
1397
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
1415 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
1416 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
1417 #ifdef HAVE_GFC_REAL_10
1418 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
1419 #endif
1420 #ifdef HAVE_GFC_REAL_16
1421 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
1422 #endif
1423 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
1424
1425 ! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
1426
1427 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
1428 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
1429 #ifdef HAVE_GFC_REAL_10
1430 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
1431 #endif
1432 #ifdef HAVE_GFC_REAL_16
1433 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
1434 #endif
1435 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
1436
1437 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
1438 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
1439 #ifdef HAVE_GFC_REAL_10
1440 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
1441 #endif
1442 #ifdef HAVE_GFC_REAL_16
1443 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
1444 #endif
1445 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
1446
1447 ! IEEE_SUPPORT_DIVIDE
1448
1449 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
1450 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
1451 #ifdef HAVE_GFC_REAL_10
1452 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
1453 #endif
1454 #ifdef HAVE_GFC_REAL_16
1455 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
1456 #endif
1457 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
1458
1459 ! IEEE_SUPPORT_INF
1460
1461 SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
1462 SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
1463 #ifdef HAVE_GFC_REAL_10
1464 SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
1465 #endif
1466 #ifdef HAVE_GFC_REAL_16
1467 SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
1468 #endif
1469 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
1470
1471 ! IEEE_SUPPORT_IO
1472
1473 SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
1474 SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
1475 #ifdef HAVE_GFC_REAL_10
1476 SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
1477 #endif
1478 #ifdef HAVE_GFC_REAL_16
1479 SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
1480 #endif
1481 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
1482
1483 ! IEEE_SUPPORT_NAN
1484
1485 SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
1486 SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
1487 #ifdef HAVE_GFC_REAL_10
1488 SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
1489 #endif
1490 #ifdef HAVE_GFC_REAL_16
1491 SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
1492 #endif
1493 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
1494
1495 ! IEEE_SUPPORT_SQRT
1496
1497 SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
1498 SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
1499 #ifdef HAVE_GFC_REAL_10
1500 SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
1501 #endif
1502 #ifdef HAVE_GFC_REAL_16
1503 SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
1504 #endif
1505 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
1506
1507 ! IEEE_SUPPORT_STANDARD
1508
1509 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
1510 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
1511 #ifdef HAVE_GFC_REAL_10
1512 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
1513 #endif
1514 #ifdef HAVE_GFC_REAL_16
1515 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
1516 #endif
1517 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
1518
1519 end module IEEE_ARITHMETIC