libgfortran/ieee/ieee_arithmetic.F90

   1 !    Implementation of the IEEE_ARITHMETIC standard intrinsic module
   2 !    Copyright (C) 2013 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_ZERO     = IEEE_CLASS_TYPE(6), &
  59     IEEE_POSITIVE_ZERO     = IEEE_CLASS_TYPE(7), &
  60     IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), &
  61     IEEE_POSITIVE_NORMAL   = IEEE_CLASS_TYPE(9), &
  62     IEEE_POSITIVE_INF      = IEEE_CLASS_TYPE(10)
  63
  64   type, public :: IEEE_ROUND_TYPE
  65     private
  66     integer :: hidden
  67   end type
  68
  69   type(IEEE_ROUND_TYPE), parameter, public :: &
  70     IEEE_NEAREST           = IEEE_ROUND_TYPE(GFC_FPE_TONEAREST), &
  71     IEEE_TO_ZERO           = IEEE_ROUND_TYPE(GFC_FPE_TOWARDZERO), &
  72     IEEE_UP                = IEEE_ROUND_TYPE(GFC_FPE_UPWARD), &
  73     IEEE_DOWN              = IEEE_ROUND_TYPE(GFC_FPE_DOWNWARD), &
  74     IEEE_OTHER             = IEEE_ROUND_TYPE(0)
  75
  76
  77   ! Equality operators on the derived types
  78   interface operator (==)
  79     module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ
  80   end interface
  81   public :: operator(==)
  82
  83   interface operator (/=)
  84     module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE
  85   end interface
  86   public :: operator (/=)
  87
  88
  89   ! IEEE_IS_FINITE
  90
  91   interface
  92     elemental logical function _gfortran_ieee_is_finite_4(X)
  93       real(kind=4), intent(in) :: X
  94     end function
  95     elemental logical function _gfortran_ieee_is_finite_8(X)
  96       real(kind=8), intent(in) :: X
  97     end function
  98   end interface
  99
 100   interface IEEE_IS_FINITE
 101     procedure _gfortran_ieee_is_finite_4, _gfortran_ieee_is_finite_8
 102   end interface
 103   public :: IEEE_IS_FINITE
 104
 105   ! IEEE_IS_NAN
 106
 107   interface
 108     elemental logical function _gfortran_ieee_is_nan_4(X)
 109       real(kind=4), intent(in) :: X
 110     end function
 111     elemental logical function _gfortran_ieee_is_nan_8(X)
 112       real(kind=8), intent(in) :: X
 113     end function
 114   end interface
 115
 116   interface IEEE_IS_NAN
 117     procedure _gfortran_ieee_is_nan_4, _gfortran_ieee_is_nan_8
 118   end interface
 119   public :: IEEE_IS_NAN
 120
 121   ! IEEE_IS_NEGATIVE
 122
 123   interface
 124     elemental logical function _gfortran_ieee_is_negative_4(X)
 125       real(kind=4), intent(in) :: X
 126     end function
 127     elemental logical function _gfortran_ieee_is_negative_8(X)
 128       real(kind=8), intent(in) :: X
 129     end function
 130   end interface
 131
 132   interface IEEE_IS_NEGATIVE
 133     procedure _gfortran_ieee_is_negative_4, _gfortran_ieee_is_negative_8
 134   end interface
 135   public :: IEEE_IS_NEGATIVE
 136
 137   ! IEEE_IS_NORMAL
 138
 139   interface
 140     elemental logical function _gfortran_ieee_is_normal_4(X)
 141       real(kind=4), intent(in) :: X
 142     end function
 143     elemental logical function _gfortran_ieee_is_normal_8(X)
 144       real(kind=8), intent(in) :: X
 145     end function
 146   end interface
 147
 148   interface IEEE_IS_NORMAL
 149     procedure _gfortran_ieee_is_normal_4, _gfortran_ieee_is_normal_8
 150   end interface
 151   public :: IEEE_IS_NORMAL
 152
 153   ! IEEE_COPY_SIGN
 154
 155   interface
 156     elemental real(kind=4) function _gfortran_ieee_copy_sign_4_4 (X,Y)
 157       real(kind=4), intent(in) :: X
 158       real(kind=4), intent(in) :: Y
 159     end function
 160     elemental real(kind=4) function _gfortran_ieee_copy_sign_4_8 (X,Y)
 161       real(kind=4), intent(in) :: X
 162       real(kind=8), intent(in) :: Y
 163     end function
 164     elemental real(kind=8) function _gfortran_ieee_copy_sign_8_4 (X,Y)
 165       real(kind=8), intent(in) :: X
 166       real(kind=4), intent(in) :: Y
 167     end function
 168     elemental real(kind=8) function _gfortran_ieee_copy_sign_8_8 (X,Y)
 169       real(kind=8), intent(in) :: X
 170       real(kind=8), intent(in) :: Y
 171     end function
 172   end interface
 173
 174   interface IEEE_COPY_SIGN
 175     procedure _gfortran_ieee_copy_sign_4_4, _gfortran_ieee_copy_sign_4_8, &
 176               _gfortran_ieee_copy_sign_8_4, _gfortran_ieee_copy_sign_8_8
 177   end interface
 178   public :: IEEE_COPY_SIGN
 179
 180   ! IEEE_UNORDERED
 181
 182   interface
 183     elemental logical function _gfortran_ieee_unordered_4_4 (X,Y)
 184       real(kind=4), intent(in) :: X
 185       real(kind=4), intent(in) :: Y
 186     end function
 187     elemental logical function _gfortran_ieee_unordered_4_8 (X,Y)
 188       real(kind=4), intent(in) :: X
 189       real(kind=8), intent(in) :: Y
 190     end function
 191     elemental logical function _gfortran_ieee_unordered_8_4 (X,Y)
 192       real(kind=8), intent(in) :: X
 193       real(kind=4), intent(in) :: Y
 194     end function
 195     elemental logical function _gfortran_ieee_unordered_8_8 (X,Y)
 196       real(kind=8), intent(in) :: X
 197       real(kind=8), intent(in) :: Y
 198     end function
 199   end interface
 200
 201   interface IEEE_UNORDERED
 202     procedure _gfortran_ieee_unordered_4_4, _gfortran_ieee_unordered_4_8, &
 203               _gfortran_ieee_unordered_8_4, _gfortran_ieee_unordered_8_8
 204   end interface
 205   public :: IEEE_UNORDERED
 206
 207   ! IEEE_LOGB
 208
 209   interface
 210     elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
 211       real(kind=4), intent(in) :: X
 212     end function
 213     elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
 214       real(kind=8), intent(in) :: X
 215     end function
 216   end interface
 217
 218   interface IEEE_LOGB
 219     procedure _gfortran_ieee_logb_4, _gfortran_ieee_logb_8
 220   end interface
 221   public :: IEEE_LOGB
 222
 223   ! IEEE_NEXT_AFTER
 224
 225   interface
 226     elemental real(kind=4) function _gfortran_ieee_next_after_4_4 (X, Y)
 227       real(kind=4), intent(in) :: X
 228       real(kind=4), intent(in) :: Y
 229     end function
 230     elemental real(kind=4) function _gfortran_ieee_next_after_4_8 (X, Y)
 231       real(kind=4), intent(in) :: X
 232       real(kind=8), intent(in) :: Y
 233     end function
 234     elemental real(kind=8) function _gfortran_ieee_next_after_8_4 (X, Y)
 235       real(kind=8), intent(in) :: X
 236       real(kind=4), intent(in) :: Y
 237     end function
 238     elemental real(kind=8) function _gfortran_ieee_next_after_8_8 (X, Y)
 239       real(kind=8), intent(in) :: X
 240       real(kind=8), intent(in) :: Y
 241     end function
 242   end interface
 243
 244   interface IEEE_NEXT_AFTER
 245     procedure _gfortran_ieee_next_after_4_4, _gfortran_ieee_next_after_4_8, &
 246               _gfortran_ieee_next_after_8_4, _gfortran_ieee_next_after_8_8
 247   end interface
 248   public :: IEEE_NEXT_AFTER
 249
 250   ! IEEE_REM
 251
 252   interface
 253     elemental real(kind=4) function _gfortran_ieee_rem_4_4 (X, Y)
 254       real(kind=4), intent(in) :: X
 255       real(kind=4), intent(in) :: Y
 256     end function
 257     elemental real(kind=8) function _gfortran_ieee_rem_4_8 (X, Y)
 258       real(kind=4), intent(in) :: X
 259       real(kind=8), intent(in) :: Y
 260     end function
 261     elemental real(kind=8) function _gfortran_ieee_rem_8_4 (X, Y)
 262       real(kind=8), intent(in) :: X
 263       real(kind=4), intent(in) :: Y
 264     end function
 265     elemental real(kind=8) function _gfortran_ieee_rem_8_8 (X, Y)
 266       real(kind=8), intent(in) :: X
 267       real(kind=8), intent(in) :: Y
 268     end function
 269   end interface
 270
 271   interface IEEE_REM
 272     procedure _gfortran_ieee_rem_4_4, _gfortran_ieee_rem_4_8, &
 273               _gfortran_ieee_rem_8_4, _gfortran_ieee_rem_8_8
 274   end interface
 275   public :: IEEE_REM
 276
 277   ! IEEE_RINT
 278
 279   interface
 280     elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
 281       real(kind=4), intent(in) :: X
 282     end function
 283     elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
 284       real(kind=8), intent(in) :: X
 285     end function
 286   end interface
 287
 288   interface IEEE_RINT
 289     procedure _gfortran_ieee_rint_4, _gfortran_ieee_rint_8
 290   end interface
 291   public :: IEEE_RINT
 292
 293   ! IEEE_SCALB
 294
 295   interface
 296     elemental real(kind=4) function _gfortran_ieee_scalb_4 (X, I)
 297       real(kind=4), intent(in) :: X
 298       integer, intent(in) :: I
 299     end function
 300     elemental real(kind=8) function _gfortran_ieee_scalb_8 (X, I)
 301       real(kind=8), intent(in) :: X
 302       integer, intent(in) :: I
 303     end function
 304   end interface
 305
 306   interface IEEE_SCALB
 307     procedure _gfortran_ieee_scalb_4, _gfortran_ieee_scalb_8
 308   end interface
 309   public :: IEEE_SCALB
 310
 311   ! IEEE_VALUE
 312
 313   interface IEEE_VALUE
 314     module procedure IEEE_VALUE_4, IEEE_VALUE_8
 315   end interface
 316   public :: IEEE_VALUE
 317
 318   ! IEEE_CLASS
 319
 320   interface IEEE_CLASS
 321     module procedure IEEE_CLASS_4, IEEE_CLASS_8
 322   end interface
 323   public :: IEEE_CLASS
 324
 325   ! Public declarations for contained procedures
 326   public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
 327   public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
 328   public :: IEEE_SELECTED_REAL_KIND
 329
 330   ! IEEE_SUPPORT_ROUNDING
 331
 332   interface IEEE_SUPPORT_ROUNDING
 333     module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
 334 #ifdef HAVE_GFC_REAL_10
 335                      IEEE_SUPPORT_ROUNDING_10, &
 336 #endif
 337 #ifdef HAVE_GFC_REAL_16
 338                      IEEE_SUPPORT_ROUNDING_16, &
 339 #endif
 340                      IEEE_SUPPORT_ROUNDING_NOARG
 341   end interface
 342   public :: IEEE_SUPPORT_ROUNDING
 343
 344   ! Interface to the FPU-specific function
 345   interface
 346     pure integer function support_rounding_helper(flag) &
 347         bind(c, name="_gfortrani_support_fpu_rounding_mode")
 348       integer, intent(in), value :: flag
 349     end function
 350   end interface
 351
 352   ! IEEE_SUPPORT_UNDERFLOW_CONTROL
 353
 354   interface IEEE_SUPPORT_UNDERFLOW_CONTROL
 355     module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, &
 356                      IEEE_SUPPORT_UNDERFLOW_CONTROL_8, &
 357 #ifdef HAVE_GFC_REAL_10
 358                      IEEE_SUPPORT_UNDERFLOW_CONTROL_10, &
 359 #endif
 360 #ifdef HAVE_GFC_REAL_16
 361                      IEEE_SUPPORT_UNDERFLOW_CONTROL_16, &
 362 #endif
 363                      IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG
 364   end interface
 365   public :: IEEE_SUPPORT_UNDERFLOW_CONTROL
 366
 367   ! Interface to the FPU-specific function
 368   interface
 369     pure integer function support_underflow_control_helper(kind) &
 370         bind(c, name="_gfortrani_support_fpu_underflow_control")
 371       integer, intent(in), value :: kind
 372     end function
 373   end interface
 374
 375 ! IEEE_SUPPORT_* generic functions
 376
 377 #if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
 378 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
 379 #elif defined(HAVE_GFC_REAL_10)
 380 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
 381 #elif defined(HAVE_GFC_REAL_16)
 382 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
 383 #else
 384 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
 385 #endif
 386
 387 #define SUPPORTGENERIC(NAME) \
 388   interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
 389   public :: NAME
 390
 391 SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
 392 SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
 393 SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
 394 SUPPORTGENERIC(IEEE_SUPPORT_INF)
 395 SUPPORTGENERIC(IEEE_SUPPORT_IO)
 396 SUPPORTGENERIC(IEEE_SUPPORT_NAN)
 397 SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
 398 SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
 399
 400 contains
 401
 402   ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
 403   elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
 404     implicit none
 405     type(IEEE_CLASS_TYPE), intent(in) :: X, Y
 406     res = (X%hidden == Y%hidden)
 407   end function
 408
 409   elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
 410     implicit none
 411     type(IEEE_CLASS_TYPE), intent(in) :: X, Y
 412     res = (X%hidden /= Y%hidden)
 413   end function
 414
 415   elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
 416     implicit none
 417     type(IEEE_ROUND_TYPE), intent(in) :: X, Y
 418     res = (X%hidden == Y%hidden)
 419   end function
 420
 421   elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
 422     implicit none
 423     type(IEEE_ROUND_TYPE), intent(in) :: X, Y
 424     res = (X%hidden /= Y%hidden)
 425   end function
 426
 427   ! IEEE_SELECTED_REAL_KIND
 428   integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
 429     implicit none
 430     integer, intent(in), optional :: P, R, RADIX
 431     integer :: p2, r2
 432
 433     p2 = 0 ; r2 = 0
 434     if (present(p)) p2 = p
 435     if (present(r)) r2 = r
 436
 437     ! The only IEEE types we support right now are binary
 438     if (present(radix)) then
 439       if (radix /= 2) then
 440         res = -5
 441         return
 442       endif
 443     endif
 444
 445     ! Does IEEE float fit?
 446     if (precision(0.) >= p2 .and. range(0.) >= r2) then
 447       res = kind(0.)
 448       return
 449     endif
 450
 451     ! Does IEEE double fit?
 452     if (precision(0.d0) >= p2 .and. range(0.d0) >= r2) then
 453       res = kind(0.d0)
 454       return
 455     endif
 456
 457     if (precision(0.d0) < p2 .and. range(0.d0) < r2) then
 458       res = -3
 459       return
 460     endif
 461
 462     if (precision(0.d0) < p2) then
 463       res = -1
 464       return
 465     endif
 466
 467    res = -2
 468   end function
 469
 470
 471   ! IEEE_CLASS
 472
 473   elemental function IEEE_CLASS_4 (X) result(res)
 474     implicit none
 475     real(kind=4), intent(in) :: X
 476     type(IEEE_CLASS_TYPE) :: res
 477
 478     interface
 479       pure integer function _gfortrani_ieee_class_helper_4(val)
 480         real(kind=4), intent(in) :: val
 481       end function
 482     end interface
 483
 484     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
 485   end function
 486
 487   elemental function IEEE_CLASS_8 (X) result(res)
 488     implicit none
 489     real(kind=8), intent(in) :: X
 490     type(IEEE_CLASS_TYPE) :: res
 491
 492     interface
 493       pure integer function _gfortrani_ieee_class_helper_8(val)
 494         real(kind=8), intent(in) :: val
 495       end function
 496     end interface
 497
 498     res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
 499   end function
 500
 501   ! IEEE_VALUE
 502
 503   elemental real(kind=4) function IEEE_VALUE_4(X, C) result(res)
 504     implicit none
 505     real(kind=4), intent(in) :: X
 506     type(IEEE_CLASS_TYPE), intent(in) :: C
 507
 508     select case (C%hidden)
 509       case (1)     ! IEEE_SIGNALING_NAN
 510         res = -1
 511         res = sqrt(res)
 512       case (2)     ! IEEE_QUIET_NAN
 513         res = -1
 514         res = sqrt(res)
 515       case (3)     ! IEEE_NEGATIVE_INF
 516         res = huge(res)
 517         res = (-res) * res
 518       case (4)     ! IEEE_NEGATIVE_NORMAL
 519         res = -42
 520       case (5)     ! IEEE_NEGATIVE_DENORMAL
 521         res = -tiny(res)
 522         res = res / 2
 523       case (6)     ! IEEE_NEGATIVE_ZERO
 524         res = 0
 525         res = -res
 526       case (7)     ! IEEE_POSITIVE_ZERO
 527         res = 0
 528       case (8)     ! IEEE_POSITIVE_DENORMAL
 529         res = tiny(res)
 530         res = res / 2
 531       case (9)     ! IEEE_POSITIVE_NORMAL
 532         res = 42
 533       case (10)    ! IEEE_POSITIVE_INF
 534         res = huge(res)
 535         res = res * res
 536       case default ! IEEE_OTHER_VALUE, should not happen
 537         res = 0
 538      end select
 539   end function
 540
 541   elemental real(kind=8) function IEEE_VALUE_8(X, C) result(res)
 542     implicit none
 543     real(kind=8), intent(in) :: X
 544     type(IEEE_CLASS_TYPE), intent(in) :: C
 545
 546     select case (C%hidden)
 547       case (1)     ! IEEE_SIGNALING_NAN
 548         res = -1
 549         res = sqrt(res)
 550       case (2)     ! IEEE_QUIET_NAN
 551         res = -1
 552         res = sqrt(res)
 553       case (3)     ! IEEE_NEGATIVE_INF
 554         res = huge(res)
 555         res = (-res) * res
 556       case (4)     ! IEEE_NEGATIVE_NORMAL
 557         res = -42
 558       case (5)     ! IEEE_NEGATIVE_DENORMAL
 559         res = -tiny(res)
 560         res = res / 2
 561       case (6)     ! IEEE_NEGATIVE_ZERO
 562         res = 0
 563         res = -res
 564       case (7)     ! IEEE_POSITIVE_ZERO
 565         res = 0
 566       case (8)     ! IEEE_POSITIVE_DENORMAL
 567         res = tiny(res)
 568         res = res / 2
 569       case (9)     ! IEEE_POSITIVE_NORMAL
 570         res = 42
 571       case (10)    ! IEEE_POSITIVE_INF
 572         res = huge(res)
 573         res = res * res
 574       case default ! IEEE_OTHER_VALUE, should not happen
 575         res = 0
 576      end select
 577   end function
 578
 579
 580   ! IEEE_GET_ROUNDING_MODE
 581
 582   subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
 583     implicit none
 584     type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
 585
 586     interface
 587       integer function helper() &
 588         bind(c, name="_gfortrani_get_fpu_rounding_mode")
 589       end function
 590     end interface
 591
 592     ROUND_VALUE = IEEE_ROUND_TYPE(helper())
 593   end subroutine
 594
 595
 596   ! IEEE_SET_ROUNDING_MODE
 597
 598   subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE)
 599     implicit none
 600     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 601
 602     interface
 603       subroutine helper(val) &
 604           bind(c, name="_gfortrani_set_fpu_rounding_mode")
 605         integer, value :: val
 606       end subroutine
 607     end interface
 608
 609     call helper(ROUND_VALUE%hidden)
 610   end subroutine
 611
 612
 613   ! IEEE_GET_UNDERFLOW_MODE
 614
 615   subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
 616     implicit none
 617     logical, intent(out) :: GRADUAL
 618
 619     interface
 620       integer function helper() &
 621         bind(c, name="_gfortrani_get_fpu_underflow_mode")
 622       end function
 623     end interface
 624
 625     GRADUAL = (helper() /= 0)
 626   end subroutine
 627
 628
 629   ! IEEE_SET_UNDERFLOW_MODE
 630
 631   subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
 632     implicit none
 633     logical, intent(in) :: GRADUAL
 634
 635     interface
 636       subroutine helper(val) &
 637           bind(c, name="_gfortrani_set_fpu_underflow_mode")
 638         integer, value :: val
 639       end subroutine
 640     end interface
 641
 642     call helper(merge(1, 0, GRADUAL))
 643   end subroutine
 644
 645 ! IEEE_SUPPORT_ROUNDING
 646
 647   pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
 648     implicit none
 649     real(kind=4), intent(in) :: X
 650     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 651     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
 652   end function
 653
 654   pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
 655     implicit none
 656     real(kind=8), intent(in) :: X
 657     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 658     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
 659   end function
 660
 661 #ifdef HAVE_GFC_REAL_10
 662   pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
 663     implicit none
 664     real(kind=10), intent(in) :: X
 665     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 666     res = .false.
 667   end function
 668 #endif
 669
 670 #ifdef HAVE_GFC_REAL_16
 671   pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
 672     implicit none
 673     real(kind=16), intent(in) :: X
 674     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 675     res = .false.
 676   end function
 677 #endif
 678
 679   pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
 680     implicit none
 681     type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
 682 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 683     res = .false.
 684 #else
 685     res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
 686 #endif
 687   end function
 688
 689 ! IEEE_SUPPORT_UNDERFLOW_CONTROL
 690
 691   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res)
 692     implicit none
 693     real(kind=4), intent(in) :: X
 694     res = (support_underflow_control_helper(4) /= 0)
 695   end function
 696
 697   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res)
 698     implicit none
 699     real(kind=8), intent(in) :: X
 700     res = (support_underflow_control_helper(8) /= 0)
 701   end function
 702
 703 #ifdef HAVE_GFC_REAL_10
 704   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res)
 705     implicit none
 706     real(kind=10), intent(in) :: X
 707     res = .false.
 708   end function
 709 #endif
 710
 711 #ifdef HAVE_GFC_REAL_16
 712   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res)
 713     implicit none
 714     real(kind=16), intent(in) :: X
 715     res = .false.
 716   end function
 717 #endif
 718
 719   pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
 720     implicit none
 721 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 722     res = .false.
 723 #else
 724     res = (support_underflow_control_helper(4) /= 0 &
 725            .and. support_underflow_control_helper(8) /= 0)
 726 #endif
 727   end function
 728
 729 ! IEEE_SUPPORT_* functions
 730
 731 #define SUPPORTMACRO(NAME, INTKIND, VALUE) \
 732   pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
 733     implicit none                                            ; \
 734     real(INTKIND), intent(in) :: X(..)                       ; \
 735     res = VALUE                                              ; \
 736   end function
 737
 738 #define SUPPORTMACRO_NOARG(NAME, VALUE) \
 739   pure logical function NAME/**/_NOARG () result(res) ; \
 740     implicit none                                     ; \
 741     res = VALUE                                       ; \
 742   end function
 743
 744 ! IEEE_SUPPORT_DATATYPE
 745
 746 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
 747 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
 748 #ifdef HAVE_GFC_REAL_10
 749 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.false.)
 750 #endif
 751 #ifdef HAVE_GFC_REAL_16
 752 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.false.)
 753 #endif
 754 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 755 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.false.)
 756 #else
 757 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
 758 #endif
 759
 760 ! IEEE_SUPPORT_DENORMAL
 761
 762 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
 763 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
 764 #ifdef HAVE_GFC_REAL_10
 765 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.false.)
 766 #endif
 767 #ifdef HAVE_GFC_REAL_16
 768 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.false.)
 769 #endif
 770 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 771 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.false.)
 772 #else
 773 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
 774 #endif
 775
 776 ! IEEE_SUPPORT_DIVIDE
 777
 778 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
 779 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
 780 #ifdef HAVE_GFC_REAL_10
 781 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.false.)
 782 #endif
 783 #ifdef HAVE_GFC_REAL_16
 784 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.false.)
 785 #endif
 786 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 787 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.false.)
 788 #else
 789 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
 790 #endif
 791
 792 ! IEEE_SUPPORT_INF
 793
 794 SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
 795 SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
 796 #ifdef HAVE_GFC_REAL_10
 797 SUPPORTMACRO(IEEE_SUPPORT_INF,10,.false.)
 798 #endif
 799 #ifdef HAVE_GFC_REAL_16
 800 SUPPORTMACRO(IEEE_SUPPORT_INF,16,.false.)
 801 #endif
 802 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 803 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.false.)
 804 #else
 805 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
 806 #endif
 807
 808 ! IEEE_SUPPORT_IO
 809
 810 SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
 811 SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
 812 #ifdef HAVE_GFC_REAL_10
 813 SUPPORTMACRO(IEEE_SUPPORT_IO,10,.false.)
 814 #endif
 815 #ifdef HAVE_GFC_REAL_16
 816 SUPPORTMACRO(IEEE_SUPPORT_IO,16,.false.)
 817 #endif
 818 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 819 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.false.)
 820 #else
 821 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
 822 #endif
 823
 824 ! IEEE_SUPPORT_NAN
 825
 826 SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
 827 SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
 828 #ifdef HAVE_GFC_REAL_10
 829 SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.false.)
 830 #endif
 831 #ifdef HAVE_GFC_REAL_16
 832 SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.false.)
 833 #endif
 834 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 835 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.false.)
 836 #else
 837 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
 838 #endif
 839
 840 ! IEEE_SUPPORT_SQRT
 841
 842 SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
 843 SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
 844 #ifdef HAVE_GFC_REAL_10
 845 SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.false.)
 846 #endif
 847 #ifdef HAVE_GFC_REAL_16
 848 SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.false.)
 849 #endif
 850 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 851 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.false.)
 852 #else
 853 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
 854 #endif
 855
 856 ! IEEE_SUPPORT_STANDARD
 857
 858 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
 859 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
 860 #ifdef HAVE_GFC_REAL_10
 861 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.false.)
 862 #endif
 863 #ifdef HAVE_GFC_REAL_16
 864 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.false.)
 865 #endif
 866 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
 867 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.false.)
 868 #else
 869 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
 870 #endif
 871
 872 end module IEEE_ARITHMETIC