1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Floating Point Environment */
28
29 #ifdef HAVE_CONFIG_H
30 # include "config.h"
31 #endif
32
33 #include "cmpintmd.h"
34
35 #if (defined (HAVE_FENV_H))
36 # include <fenv.h>
37 # ifdef HAVE_FENV_T
38 # define scheme_fenv_t fenv_t
39 # endif
40 # ifdef HAVE_FEXCEPT_T
41 # define scheme_fexcept_t fexcept_t
42 # endif
43 # ifdef __APPLE__
44 # undef HAVE_FEGETEXCEPT
45 # endif
46 #elif ((!defined (CMPINTMD_EMULATES_FENV)) && (defined (HAVE_IEEEFP_H)))
47
48 /* Assumption: If we have <ieeefp.h>, then we don't need to test for
49 individual definitions in it. If you come across a different
50 <ieeefp.h> from what one finds on BSD systems, you'll have to fix
51 this code. */
52
53 # include <ieeefp.h>
54
55 # ifndef FE_TONEAREST
56 # define FE_TONEAREST FP_RN
57 # endif
58
59 # ifndef FE_DOWNWARD
60 # define FE_DOWNWARD FP_RM
61 # endif
62
63 # ifndef FE_UPWARD
64 # define FE_UPWARD FP_RP
65 # endif
66
67 # ifndef FE_TOWARDZERO
68 # define FE_TOWARDZERO FP_RZ
69 # endif
70
71 # ifndef HAVE_FEGETROUND
72 # define HAVE_FEGETROUND
73 # define fegetround fpgetround
74 # endif
75
76 # ifndef HAVE_FESETROUND
77 # define HAVE_FESETROUND
78 # define fesetround(rm) ((fpsetround (rm)), 0)
79 # endif
80
81 # ifndef FE_INVALID
82 # define FE_INVALID FP_X_INV
83 # endif
84
85 # ifndef FE_DIVBYZERO
86 # define FE_DIVBYZERO FP_X_DZ
87 # endif
88
89 # ifndef FE_OVERFLOW
90 # define FE_OVERFLOW FP_X_OFL
91 # endif
92
93 # ifndef FE_UNDERFLOW
94 # define FE_UNDERFLOW FP_X_UFL
95 # endif
96
97 # ifndef FE_INEXACT
98 # define FE_INEXACT FP_X_IMP
99 # endif
100
101 # ifndef FE_ALL_EXCEPT
102 # define FE_ALL_EXCEPT \
103 (FE_DIVBYZERO | FE_INEXACT | FE_INVALID | FE_OVERFLOW | FE_UNDERFLOW)
104 # endif
105
106 /* FP_X_IOV? */
107
108 # ifndef HAVE_FEXCEPT_T
109 # define HAVE_FEXCEPT_T
110 typedef fp_except fexcept_t;
111 # endif
112
113 # ifndef HAVE_FETESTEXCEPT
114 # define HAVE_FETESTEXCEPT
115 # define fetestexcept(excepts) ((excepts) & (fpgetsticky ()))
116 # endif
117
118 # ifndef HAVE_FECLEAREXCEPT
119 # define HAVE_FECLEAREXCEPT
120 # define feclearexcept(excepts) \
121 ((fpsetsticky ((fpgetsticky ()) &~ (FE_ALL_EXCEPT & (excepts)))), 0)
122 # endif
123
124 # ifndef HAVE_FERAISEEXCEPT
125 # define HAVE_FERAISEEXCEPT
126 static inline int
feraiseexcept(int excepts)127 feraiseexcept (int excepts)
128 {
129 (void) fpsetsticky ((fpgetsticky ()) | (FE_ALL_EXCEPT & (excepts)));
130 /* Force a floating-point operation to happen, which ideally should
131 trap if there are unmasked exceptions pending, presumably because
132 of the above fpsetsticky. */
133 volatile double x = 0;
134 volatile double y = 0;
135 volatile double z = (x + y);
136 (void) z; /* ignored */
137 return (0);
138 }
139 # endif
140
141 # ifndef HAVE_FEGETEXCEPTFLAG
142 # define HAVE_FEGETEXCEPTFLAG
143 # define fegetexceptflag(flagp, excepts) \
144 (((* ((0 ? ((int *) 0) : flagp))) = ((excepts) & (fpgetsticky ()))), 0)
145 # endif
146
147 # ifndef HAVE_FESETEXCEPTFLAG
148 # define HAVE_FESETEXCEPTFLAG
149 # define fesetexceptflag(flagp, excepts) \
150 ((fpsetsticky \
151 (FE_ALL_EXCEPT & (excepts) & (* ((0 ? ((const int *) 0) : flagp))))), \
152 0)
153 # endif
154
155 # ifndef HAVE_FEGETEXCEPT
156 # define HAVE_FEGETEXCEPT
157 # define fegetexcept fpgetmask
158 # endif
159
160 # ifndef HAVE_FEENABLEEXCEPT
161 # define HAVE_FEENABLEEXCEPT
162 # define feenableexcept(excepts) \
163 (fpsetmask ((fpgetmask ()) | (FE_ALL_EXCEPT & (excepts))))
164 # endif
165
166 # ifndef HAVE_FEDISABLEEXCEPT
167 # define HAVE_FEDISABLEEXCEPT
168 # define fedisableexcept(excepts) \
169 (fpsetmask ((fpgetmask ()) &~ (FE_ALL_EXCEPT & (excepts))))
170 # endif
171
172 /* Kludge for NetBSD<6, which only halfway supports C99 fenv cruft. */
173 # ifdef fenv_t
174 # undef fenv_t
175 # endif
176 # define fenv_t scheme_fenv_t
177 # ifndef HAVE_FENV_T
178 # define HAVE_FENV_T
179 # endif
180
181 typedef struct
182 {
183 fp_except fe_enabled_exceptions;
184 fp_except fe_sticky_exceptions;
185 fp_rnd fe_rounding_mode;
186 } fenv_t;
187
188 # define HAVE_FEGETENV
189 # define HAVE_FESETENV
190 # define HAVE_FEHOLDEXCEPT
191 # define HAVE_FEUPDATEENV
192
193 static inline int
fegetenv(fenv_t * fe)194 fegetenv (fenv_t *fe)
195 {
196 (fe->fe_enabled_exceptions) = (fpgetmask ());
197 (fe->fe_sticky_exceptions) = (fpgetsticky ());
198 (fe->fe_rounding_mode) = (fpgetround ());
199 return (0);
200 }
201
202 static inline int
fesetenv(const fenv_t * fe)203 fesetenv (const fenv_t *fe)
204 {
205 (void) fpsetmask (fe->fe_enabled_exceptions);
206 (void) fpsetsticky (fe->fe_sticky_exceptions);
207 (void) fpsetround (fe->fe_rounding_mode);
208 return (0);
209 }
210
211 static inline int
feholdexcept(fenv_t * fe)212 feholdexcept (fenv_t *fe)
213 {
214 (void) fegetenv (fe);
215 fpsetmask (0);
216 return (0);
217 }
218
219 static inline int
feupdateenv(const fenv_t * fe)220 feupdateenv (const fenv_t *fe)
221 {
222 fp_except exceptions = (fpgetsticky ());
223 (void) fesetenv (fe);
224 (void) feraiseexcept (exceptions);
225 return (0);
226 }
227 #endif
228