libgfortran/ieee/ieee_arithmetic.F90

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