libgfortran/ieee/ieee_exceptions.F90

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