libgfortran/ieee/ieee_exceptions.F90

   1 !    Implementation of the IEEE_EXCEPTIONS standard intrinsic module
   2 !    Copyright (C) 2013-2022 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   interface IEEE_SUPPORT_FLAG
  60     module procedure IEEE_SUPPORT_FLAG_4, &
  61                      IEEE_SUPPORT_FLAG_8, &
  62 #ifdef HAVE_GFC_REAL_10
  63                      IEEE_SUPPORT_FLAG_10, &
  64 #endif
  65 #ifdef HAVE_GFC_REAL_16
  66                      IEEE_SUPPORT_FLAG_16, &
  67 #endif
  68                      IEEE_SUPPORT_FLAG_NOARG
  69   end interface IEEE_SUPPORT_FLAG
  70
  71   public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
  72   public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
  73   public :: IEEE_SET_FLAG, IEEE_GET_FLAG
  74   public :: IEEE_SET_STATUS, IEEE_GET_STATUS
  75
  76 contains
  77
  78 ! Saving and restoring floating-point status
  79
  80   subroutine IEEE_GET_STATUS (STATUS_VALUE)
  81     implicit none
  82     type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
  83
  84     interface
  85       subroutine helper(ptr) &
  86           bind(c, name="_gfortrani_get_fpu_state")
  87         use, intrinsic :: iso_c_binding, only : c_char
  88         character(kind=c_char) :: ptr(*)
  89       end subroutine
  90     end interface
  91
  92     call helper(STATUS_VALUE%hidden)
  93   end subroutine
  94
  95   subroutine IEEE_SET_STATUS (STATUS_VALUE)
  96     implicit none
  97     type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
  98
  99     interface
 100       subroutine helper(ptr) &
 101           bind(c, name="_gfortrani_set_fpu_state")
 102         use, intrinsic :: iso_c_binding, only : c_char
 103         character(kind=c_char) :: ptr(*)
 104       end subroutine
 105     end interface
 106
 107     call helper(STATUS_VALUE%hidden)
 108   end subroutine
 109
 110 ! Getting and setting flags
 111
 112   elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
 113     implicit none
 114     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 115     logical, intent(out) :: FLAG_VALUE
 116
 117     interface
 118       pure integer function helper() &
 119         bind(c, name="_gfortrani_get_fpu_except_flags")
 120       end function
 121     end interface
 122
 123     FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
 124   end subroutine
 125
 126   elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
 127     implicit none
 128     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 129     logical, intent(in) :: FLAG_VALUE
 130
 131     interface
 132       pure subroutine helper(set, clear) &
 133           bind(c, name="_gfortrani_set_fpu_except_flags")
 134         integer, intent(in), value :: set, clear
 135       end subroutine
 136     end interface
 137
 138     if (FLAG_VALUE) then
 139       call helper(FLAG%hidden, 0)
 140     else
 141       call helper(0, FLAG%hidden)
 142     end if
 143   end subroutine
 144
 145 ! Querying and changing the halting mode
 146
 147   elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
 148     implicit none
 149     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 150     logical, intent(out) :: HALTING
 151
 152     interface
 153       pure integer function helper() &
 154           bind(c, name="_gfortrani_get_fpu_trap_exceptions")
 155       end function
 156     end interface
 157
 158     HALTING = (IAND(helper(), FLAG%hidden) /= 0)
 159   end subroutine
 160
 161   elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
 162     implicit none
 163     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 164     logical, intent(in) :: HALTING
 165
 166     interface
 167       pure subroutine helper(trap, notrap) &
 168           bind(c, name="_gfortrani_set_fpu_trap_exceptions")
 169         integer, intent(in), value :: trap, notrap
 170       end subroutine
 171     end interface
 172
 173     if (HALTING) then
 174       call helper(FLAG%hidden, 0)
 175     else
 176       call helper(0, FLAG%hidden)
 177     end if
 178   end subroutine
 179
 180 ! Querying support
 181
 182   pure logical function IEEE_SUPPORT_HALTING (FLAG)
 183     implicit none
 184     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 185
 186     interface
 187       pure integer function helper(flag) &
 188           bind(c, name="_gfortrani_support_fpu_trap")
 189         integer, intent(in), value :: flag
 190       end function
 191     end interface
 192
 193     IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
 194   end function
 195
 196   pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
 197     implicit none
 198     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 199
 200     interface
 201       pure integer function helper(flag) &
 202           bind(c, name="_gfortrani_support_fpu_flag")
 203         integer, intent(in), value :: flag
 204       end function
 205     end interface
 206
 207     IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
 208   end function
 209
 210   pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
 211     implicit none
 212     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 213     real(kind=4), intent(in) :: X
 214     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 215   end function
 216
 217   pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
 218     implicit none
 219     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 220     real(kind=8), intent(in) :: X
 221     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 222   end function
 223
 224 #ifdef HAVE_GFC_REAL_10
 225   pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
 226     implicit none
 227     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 228     real(kind=10), intent(in) :: X
 229     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 230   end function
 231 #endif
 232
 233 #ifdef HAVE_GFC_REAL_16
 234   pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
 235     implicit none
 236     type(IEEE_FLAG_TYPE), intent(in) :: FLAG
 237     real(kind=16), intent(in) :: X
 238     res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
 239   end function
 240 #endif
 241
 242 end module IEEE_EXCEPTIONS