1! Implementation of the IEEE_EXCEPTIONS standard intrinsic module 2! Copyright (C) 2013-2016 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 31module 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 76contains 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 242end module IEEE_EXCEPTIONS 243