libgfortran/ieee/ieee_exceptions.F90

   1 !    Implementation of the IEEE_EXCEPTIONS standard intrinsic module
   2 !    Copyright (C) 2013-2023 Free Software Foundation, Inc.
   3 !    Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
   4 !
   5 ! This file is part of the GNU Fortran runtime library (libgfortran).
   6 !
   7 ! Libgfortran is free software; you can redistribute it and/or
   8 ! modify it under the terms of the GNU General Public
   9 ! License as published by the Free Software Foundation; either
  10 ! version 3 of the License, or (at your option) any later version.
  11 !
  12 ! Libgfortran is distributed in the hope that it will be useful,
  13 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ! GNU General Public License for more details.
  16 !
  17 ! Under Section 7 of GPL version 3, you are granted additional
  18 ! permissions described in the GCC Runtime Library Exception, version
  19 ! 3.1, as published by the Free Software Foundation.
  20 !
  21 ! You should have received a copy of the GNU General Public License and
  22 ! a copy of the GCC Runtime Library Exception along with this program;
  23 ! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 ! <http://www.gnu.org/licenses/>.  */
  25
  26 #include "config.h"
  27 #include "kinds.inc"
  28 #include "c99_protos.inc"
  29 #include "fpu-target.inc"
  30
  31 module IEEE_EXCEPTIONS
  32
  33   implicit none
  34   private
  35
  36 ! Derived types and named constants
  37
  38   type, public :: IEEE_FLAG_TYPE
  39     private
  40     integer :: hidden
  41   end type
  42
  43   type(IEEE_FLAG_TYPE), parameter, public :: &
  44     IEEE_INVALID        = IEEE_FLAG_TYPE(GFC_FPE_INVALID), &
  45     IEEE_OVERFLOW       = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), &
  46     IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), &
  47     IEEE_UNDERFLOW      = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), &
  48     IEEE_INEXACT        = IEEE_FLAG_TYPE(GFC_FPE_INEXACT)
  49
  50   type(IEEE_FLAG_TYPE), parameter, public :: &
  51     IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], &
  52     IEEE_ALL(5)   = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ]
  53
  54   type, public :: IEEE_STATUS_TYPE
  55     private
  56     character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
  57   end type
  58
  59   type, public :: IEEE_MODES_TYPE
  60     private
  61     integer :: rounding
  62     integer :: underflow
  63     integer :: halting
  64   end type
  65
  66   interface IEEE_SUPPORT_FLAG
  67     module procedure IEEE_SUPPORT_FLAG_4, &
  68                      IEEE_SUPPORT_FLAG_8, &
  69 #ifdef HAVE_GFC_REAL_10
  70                      IEEE_SUPPORT_FLAG_10, &
  71 #endif
  72 #ifdef HAVE_GFC_REAL_16
  73                      IEEE_SUPPORT_FLAG_16, &
  74 #endif
  75                      IEEE_SUPPORT_FLAG_NOARG
  76   end interface IEEE_SUPPORT_FLAG
  77
  78   public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
  79   public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
  80   public :: IEEE_SET_FLAG, IEEE_GET_FLAG
  81   public :: IEEE_SET_STATUS, IEEE_GET_STATUS
  82   public :: IEEE_SET_MODES, IEEE_GET_MODES
  83
  84 contains
  85
  86 ! Fortran 2018: Saving and restoring floating-point modes
  87 ! (rounding modes, underflow mode, and halting mode)
  88 !
  89 ! For now, we only have one rounding mode for all kinds.
  90 ! Some targets could optimize getting/setting all modes at once, but for now
  91 ! we make three calls.  This code must be kept in sync with:
  92 !   - IEEE_{GET,SET}_ROUNDING_MODE
  93 !   - IEEE_{GET,SET}_UNDERFLOW_MODE
  94 !   - IEEE_{GET,SET}_HALTING_MODE
  95
  96   subroutine IEEE_GET_MODES (MODES)
  97     implicit none
  98     type(IEEE_MODES_TYPE), intent(out) :: MODES
  99
 100     interface
 101       integer function helper_rounding() &
 102         bind(c, name="_gfortrani_get_fpu_rounding_mode")
 103       end function
 104       integer function helper_underflow() &
 105         bind(c, name="_gfortrani_get_fpu_underflow_mode")
 106       end function
 107       pure integer function helper_halting() &
 108           bind(c, name="_gfortrani_get_fpu_trap_exceptions")
 109       end function
 110     end interface
 111
 112     MODES%rounding = helper_rounding()
 113     MODES%underflow = helper_underflow()
 114     MODES%halting = helper_halting()
 115   end subroutine
 116
 117   subroutine IEEE_SET_MODES (MODES)
 118     implicit none
 119     type(IEEE_MODES_TYPE), intent(in) :: MODES
 120
 121     interface
 122       subroutine helper_rounding(val) &
 123           bind(c, name="_gfortrani_set_fpu_rounding_mode")
 124         integer, value :: val
 125       end subroutine
 126       subroutine helper_underflow(val) &
 127           bind(c, name="_gfortrani_set_fpu_underflow_mode")
 128         integer, value :: val
 129       end subroutine
 130       pure subroutine helper_halting(trap, notrap) &
 131           bind(c, name="_gfortrani_set_fpu_trap_exceptions")
 132         integer, intent(in), value :: trap, notrap
 133       end subroutine
 134     end interface
 135
 136     call helper_rounding(MODES%rounding)
 137     call helper_underflow(MODES%underflow)
 138     call helper_halting(MODES%halting, NOT(MODES%halting))
 139   end subroutine
 140
 141 ! Saving and restoring floating-point status
 142
 143   subroutine IEEE_GET_STATUS (STATUS_VALUE)
 144     implicit none
 145     type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
 146
 147     interface
 148       subroutine helper(ptr) &
 149           bind(c, name="_gfortrani_get_fpu_state")
 150         use, intrinsic :: iso_c_binding, only : c_char
 151         character(kind=c_char) :: ptr(*)
 152       end subroutine
 153     end interface
 154
 155     call helper(STATUS_VALUE%hidden)
 156   end subroutine
 157
 158   subroutine IEEE_SET_STATUS (STATUS_VALUE)
 159     implicit none
 160     type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
 161
 162     interface
 163       subroutine helper(ptr) &
 164           bind(c, name="_gfortrani_set_fpu_state")
 165         use, intrinsic :: iso_c_binding, only : c_char
 166         character(kind=c_char) :: ptr(*)
 167       end subroutine
 168     end interface
 169
 170     call helper(STATUS_VALUE%hidden)
 171   end subroutine
 172
 173 ! Getting and setting flags
 174
 175   elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
 176     implicit none
 177     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 178     logical, intent(out) :: FLAG_VALUE
 179
 180     interface
 181       pure integer function helper() &
 182         bind(c, name="_gfortrani_get_fpu_except_flags")
 183       end function
 184     end interface
 185
 186     FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
 187   end subroutine
 188
 189   elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
 190     implicit none
 191     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 192     logical, intent(in) :: FLAG_VALUE
 193
 194     interface
 195       pure subroutine helper(set, clear) &
 196           bind(c, name="_gfortrani_set_fpu_except_flags")
 197         integer, intent(in), value :: set, clear
 198       end subroutine
 199     end interface
 200
 201     if (FLAG_VALUE) then
 202       call helper(FLAG%hidden, 0)
 203     else
 204       call helper(0, FLAG%hidden)
 205     end if
 206   end subroutine
 207
 208 ! Querying and changing the halting mode
 209
 210   elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
 211     implicit none
 212     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 213     logical, intent(out) :: HALTING
 214
 215     interface
 216       pure integer function helper() &
 217           bind(c, name="_gfortrani_get_fpu_trap_exceptions")
 218       end function
 219     end interface
 220
 221     HALTING = (IAND(helper(), FLAG%hidden) /= 0)
 222   end subroutine
 223
 224   elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
 225     implicit none
 226     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 227     logical, intent(in) :: HALTING
 228
 229     interface
 230       pure subroutine helper(trap, notrap) &
 231           bind(c, name="_gfortrani_set_fpu_trap_exceptions")
 232         integer, intent(in), value :: trap, notrap
 233       end subroutine
 234     end interface
 235
 236     if (HALTING) then
 237       call helper(FLAG%hidden, 0)
 238     else
 239       call helper(0, FLAG%hidden)
 240     end if
 241   end subroutine
 242
 243 ! Querying support
 244
 245   pure logical function IEEE_SUPPORT_HALTING (FLAG)
 246     implicit none
 247     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 248
 249     interface
 250       pure integer function helper(flag) &
 251           bind(c, name="_gfortrani_support_fpu_trap")
 252         integer, intent(in), value :: flag
 253       end function
 254     end interface
 255
 256     IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
 257   end function
 258
 259   pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
 260     implicit none
 261     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 262
 263     interface
 264       pure integer function helper(flag) &
 265           bind(c, name="_gfortrani_support_fpu_flag")
 266         integer, intent(in), value :: flag
 267       end function
 268     end interface
 269
 270     IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
 271   end function
 272
 273   pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
 274     implicit none
 275     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 276     real(kind=4), intent(in) :: X
 277     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 278   end function
 279
 280   pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
 281     implicit none
 282     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 283     real(kind=8), intent(in) :: X
 284     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 285   end function
 286
 287 #ifdef HAVE_GFC_REAL_10
 288   pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
 289     implicit none
 290     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 291     real(kind=10), intent(in) :: X
 292     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 293   end function
 294 #endif
 295
 296 #ifdef HAVE_GFC_REAL_16
 297   pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
 298     implicit none
 299     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 300     real(kind=16), intent(in) :: X
 301     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 302   end function
 303 #endif
 304
 305 end module IEEE_EXCEPTIONS