| ! Implementation of the IEEE_EXCEPTIONS standard intrinsic module |
| ! Copyright (C) 2013-2022 Free Software Foundation, Inc. |
| ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> |
| ! |
| ! This file is part of the GNU Fortran runtime library (libgfortran). |
| ! |
| ! Libgfortran is free software; you can redistribute it and/or |
| ! modify it under the terms of the GNU General Public |
| ! License as published by the Free Software Foundation; either |
| ! version 3 of the License, or (at your option) any later version. |
| ! |
| ! Libgfortran is distributed in the hope that it will be useful, |
| ! but WITHOUT ANY WARRANTY; without even the implied warranty of |
| ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| ! GNU General Public License for more details. |
| ! |
| ! Under Section 7 of GPL version 3, you are granted additional |
| ! permissions described in the GCC Runtime Library Exception, version |
| ! 3.1, as published by the Free Software Foundation. |
| ! |
| ! You should have received a copy of the GNU General Public License and |
| ! a copy of the GCC Runtime Library Exception along with this program; |
| ! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see |
| ! <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "kinds.inc" |
| #include "c99_protos.inc" |
| #include "fpu-target.inc" |
| |
| module IEEE_EXCEPTIONS |
| |
| implicit none |
| private |
| |
| ! Derived types and named constants |
| |
| type, public :: IEEE_FLAG_TYPE |
| private |
| integer :: hidden |
| end type |
| |
| type(IEEE_FLAG_TYPE), parameter, public :: & |
| IEEE_INVALID = IEEE_FLAG_TYPE(GFC_FPE_INVALID), & |
| IEEE_OVERFLOW = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), & |
| IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), & |
| IEEE_UNDERFLOW = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), & |
| IEEE_INEXACT = IEEE_FLAG_TYPE(GFC_FPE_INEXACT) |
| |
| type(IEEE_FLAG_TYPE), parameter, public :: & |
| IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], & |
| IEEE_ALL(5) = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ] |
| |
| type, public :: IEEE_STATUS_TYPE |
| private |
| character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden |
| end type |
| |
| interface IEEE_SUPPORT_FLAG |
| module procedure IEEE_SUPPORT_FLAG_4, & |
| IEEE_SUPPORT_FLAG_8, & |
| #ifdef HAVE_GFC_REAL_10 |
| IEEE_SUPPORT_FLAG_10, & |
| #endif |
| #ifdef HAVE_GFC_REAL_16 |
| IEEE_SUPPORT_FLAG_16, & |
| #endif |
| IEEE_SUPPORT_FLAG_NOARG |
| end interface IEEE_SUPPORT_FLAG |
| |
| public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING |
| public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE |
| public :: IEEE_SET_FLAG, IEEE_GET_FLAG |
| public :: IEEE_SET_STATUS, IEEE_GET_STATUS |
| |
| contains |
| |
| ! Saving and restoring floating-point status |
| |
| subroutine IEEE_GET_STATUS (STATUS_VALUE) |
| implicit none |
| type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE |
| |
| interface |
| subroutine helper(ptr) & |
| bind(c, name="_gfortrani_get_fpu_state") |
| use, intrinsic :: iso_c_binding, only : c_char |
| character(kind=c_char) :: ptr(*) |
| end subroutine |
| end interface |
| |
| call helper(STATUS_VALUE%hidden) |
| end subroutine |
| |
| subroutine IEEE_SET_STATUS (STATUS_VALUE) |
| implicit none |
| type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE |
| |
| interface |
| subroutine helper(ptr) & |
| bind(c, name="_gfortrani_set_fpu_state") |
| use, intrinsic :: iso_c_binding, only : c_char |
| character(kind=c_char) :: ptr(*) |
| end subroutine |
| end interface |
| |
| call helper(STATUS_VALUE%hidden) |
| end subroutine |
| |
| ! Getting and setting flags |
| |
| elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| logical, intent(out) :: FLAG_VALUE |
| |
| interface |
| pure integer function helper() & |
| bind(c, name="_gfortrani_get_fpu_except_flags") |
| end function |
| end interface |
| |
| FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0) |
| end subroutine |
| |
| elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| logical, intent(in) :: FLAG_VALUE |
| |
| interface |
| pure subroutine helper(set, clear) & |
| bind(c, name="_gfortrani_set_fpu_except_flags") |
| integer, intent(in), value :: set, clear |
| end subroutine |
| end interface |
| |
| if (FLAG_VALUE) then |
| call helper(FLAG%hidden, 0) |
| else |
| call helper(0, FLAG%hidden) |
| end if |
| end subroutine |
| |
| ! Querying and changing the halting mode |
| |
| elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| logical, intent(out) :: HALTING |
| |
| interface |
| pure integer function helper() & |
| bind(c, name="_gfortrani_get_fpu_trap_exceptions") |
| end function |
| end interface |
| |
| HALTING = (IAND(helper(), FLAG%hidden) /= 0) |
| end subroutine |
| |
| elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| logical, intent(in) :: HALTING |
| |
| interface |
| pure subroutine helper(trap, notrap) & |
| bind(c, name="_gfortrani_set_fpu_trap_exceptions") |
| integer, intent(in), value :: trap, notrap |
| end subroutine |
| end interface |
| |
| if (HALTING) then |
| call helper(FLAG%hidden, 0) |
| else |
| call helper(0, FLAG%hidden) |
| end if |
| end subroutine |
| |
| ! Querying support |
| |
| pure logical function IEEE_SUPPORT_HALTING (FLAG) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| |
| interface |
| pure integer function helper(flag) & |
| bind(c, name="_gfortrani_support_fpu_trap") |
| integer, intent(in), value :: flag |
| end function |
| end interface |
| |
| IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0) |
| end function |
| |
| pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| |
| interface |
| pure integer function helper(flag) & |
| bind(c, name="_gfortrani_support_fpu_flag") |
| integer, intent(in), value :: flag |
| end function |
| end interface |
| |
| IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0) |
| end function |
| |
| pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| real(kind=4), intent(in) :: X |
| res = IEEE_SUPPORT_FLAG_NOARG(FLAG) |
| end function |
| |
| pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| real(kind=8), intent(in) :: X |
| res = IEEE_SUPPORT_FLAG_NOARG(FLAG) |
| end function |
| |
| #ifdef HAVE_GFC_REAL_10 |
| pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| real(kind=10), intent(in) :: X |
| res = IEEE_SUPPORT_FLAG_NOARG(FLAG) |
| end function |
| #endif |
| |
| #ifdef HAVE_GFC_REAL_16 |
| pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res) |
| implicit none |
| type(IEEE_FLAG_TYPE), intent(in) :: FLAG |
| real(kind=16), intent(in) :: X |
| res = IEEE_SUPPORT_FLAG_NOARG(FLAG) |
| end function |
| #endif |
| |
| end module IEEE_EXCEPTIONS |