1 /*
2 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3 %
4 % File: PXK:FLOAT.C
5 % Description: Miscellaneous floating point support routines for armv6 (Raspberry Pi)
6 % Author: Leigh Stoller
7 % Created: 29-Oct-86
8 % Modified:
9 % Mode: Text
10 % Package:
11 % Status: Open Source: BSD License
12 %
13 % (c) Copyright 1982, University of Utah
14 %
15 % Redistribution and use in source and binary forms, with or without
16 % modification, are permitted provided that the following conditions are met:
17 %
18 % * Redistributions of source code must retain the relevant copyright
19 % notice, this list of conditions and the following disclaimer.
20 % * Redistributions in binary form must reproduce the above copyright
21 % notice, this list of conditions and the following disclaimer in the
22 % documentation and/or other materials provided with the distribution.
23 %
24 % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
25 % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
26 % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27 % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
28 % CONTRIBUTORS
29 % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
30 % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
31 % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
32 % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
33 % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
34 % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
35 % POSSIBILITY OF SUCH DAMAGE.
36 %
37 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
38 %
39 % Revisions:
40 %
41 % 05-May-87 (Leigh Stoller)
42 % Added C defintions for external float routines used in fast-math.sl.
43 %
44 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
45 */
46
47 #include <stdio.h>
48 #include <string.h>
49 #include <math.h>
50 #include <fenv.h>
51
52 #ifdef USE_CRLIBM
53 #include "crlibm.h"
54
55 #define sin sin_rn
56 #define cos cos_rn
57 #define tan tan_rn
58 #define asin asin_rn
59 #define acos acos_rn
60 #define atan atan_rn
61 #define exp exp_rn
62 #define log log_rn
63
64 #endif
65
66 /* Tag( uxfloat )
67 */
68 void
uxfloat(f,i)69 uxfloat(f,i)
70 double *f;
71 long long i;
72 {
73 *f = i;
74 }
75
76 /* Tag( uxfix )
77 */
uxfix(f)78 long long uxfix(f)
79 double *f;
80 {
81 return *f;
82 }
83
84 /* Tag( uxassign )
85 */
86 void
uxassign(f1,f2)87 uxassign(f1,f2)
88 double *f1, *f2;
89 {
90 *f1 = *f2;
91 }
92
93 fexcept_t flagp;
94
95 long long
uxminus(f1,f2)96 uxminus(f1,f2)
97 double *f1, *f2;
98 {
99 *f1 = -*f2;
100 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
101 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
102 return (1);
103 }
104
105 /* Tag( uxplus2 )
106 */
107 long long
uxplus2(f1,f2,f3)108 uxplus2(f1,f2,f3)
109 double *f1, *f2, *f3;
110 {
111 *f1 = *f2 + *f3;
112 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
113 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
114 return (1);
115 }
116
117 /* Tag( uxdifference )
118 */
119 long long
uxdifference(f1,f2,f3)120 uxdifference(f1,f2,f3)
121 double *f1, *f2, *f3;
122 {
123 *f1 = *f2 - *f3;
124 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
125 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
126 return (1);
127 }
128
129 /* Tag( uxtimes2 )
130 */
131 long long
uxtimes2(f1,f2,f3)132 uxtimes2(f1,f2,f3)
133 double *f1, *f2, *f3;
134 {
135 *f1 = *f2 * *f3;
136 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
137 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
138 return (1);
139 }
140
141 /* Tag( uxquotient )
142 */
143 long long
uxquotient(f1,f2,f3)144 uxquotient(f1,f2,f3)
145 double *f1, *f2, *f3;
146 {
147 *f1 = *f2 / *f3;
148 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
149 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
150 return (1);
151 }
152
153 /* Tag( uxgreaterp )
154 */
uxgreaterp(f1,f2,val1,val2)155 long long uxgreaterp(f1,f2,val1,val2)
156 double *f1, *f2;
157 long long val1, val2;
158 {
159 if (*f1 > *f2)
160 return val1;
161 else
162 return val2;
163 }
164
165 /* Tag( uxlessp )
166 */
uxlessp(f1,f2,val1,val2)167 long long uxlessp(f1,f2,val1,val2)
168 double *f1, *f2;
169 long long val1, val2;
170 {
171 if (*f1 < *f2)
172 return val1;
173 else
174 return val2;
175 }
176
177 /* Tag( uxwritefloat )
178 */
179 void
uxwritefloat(buf,flt,convstr)180 uxwritefloat(buf, flt, convstr)
181 char *buf; /* String buffer to return float int */
182 double *flt; /* Pointer to the float */
183 char *convstr; /* String containing conversion field for sprintf */
184 {
185 char *temps, *dot, *e;
186 char tempbuf[102]; /* reasonable size limit */
187
188 temps = buf + 8; /* Skip over lisp string length to write data */
189
190 snprintf(temps, 99, convstr, *flt);
191
192 if (finite(*flt))
193 {
194 /* Make sure that there is a trailing .0
195 */
196 dot = rindex(temps, '.');
197 if (dot == NULL)
198 {
199 /* Check to see if the number is in scientific notation. If so, we need
200 * add the .0 into the middle of the string, just before the e.
201 */
202 if ((e = rindex(temps, 'e')) || (e = rindex(temps, 'E')))
203 {
204 strcpy(tempbuf, e); /* save save exponent part */
205 *e = '\0';
206 strcat(temps, ".0"); /* Add .0 onto original string */
207 strcat(temps, tempbuf); /* add the exponent part onto the end */
208 }
209 else
210 {
211 strcat(temps, ".0");
212 }
213 }
214 }
215 /* Install the length of the string into the Lisp header word
216 */
217 *((long long *)buf) = strlen(temps) - 1;
218 }
219
220
221 /* Tag( uxdoubletofloat )
222 */
223 void
uxdoubletofloat(dbl,flt)224 uxdoubletofloat (dbl,flt)
225 double *dbl;
226 float *flt;
227 {
228 *flt = (float) *dbl;
229 }
230
231 void
uxfloattodouble(flt,dbl)232 uxfloattodouble (flt,dbl)
233 float *flt;
234 double *dbl;
235 {
236 *dbl = (double) *flt;
237 }
238
239 /* Functions for fast-math.sl (Unix C replacement for mathlib.) */
240 long long
uxsin(r,x)241 uxsin (r, x)
242 double *r, *x;
243 {
244 *r = sin( *x );
245 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
246 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
247 return (1);
248 }
249
250 long long
uxcos(r,x)251 uxcos (r, x)
252 double *r, *x;
253 {
254 *r = cos( *x );
255 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
256 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
257 return (1);
258 }
259
260 long long
uxtan(r,x)261 uxtan (r, x)
262 double *r, *x;
263 {
264 *r = tan( *x );
265 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
266 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
267 return (1);
268 }
269
270 long long
uxasin(r,x)271 uxasin (r, x)
272 double *r, *x;
273 {
274 *r = asin( *x );
275 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
276 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
277 return (1);
278 }
279
280 long long
uxacos(r,x)281 uxacos (r, x)
282 double *r, *x;
283 {
284 *r = acos( *x );
285 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
286 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
287 return (1);
288 }
289
290 long long
uxatan(r,x)291 uxatan (r, x)
292 double *r, *x;
293 {
294 *r = atan( *x );
295 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
296 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
297 return (1);
298 }
299
300 long long
uxsqrt(r,x)301 uxsqrt (r, x)
302 double *r, *x;
303 {
304 *r = sqrt( *x );
305 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
306 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
307 return (1);
308 }
309
310 long long
uxexp(r,x)311 uxexp (r, x)
312 double *r, *x;
313 {
314 *r = exp( *x );
315 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
316 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
317 return (1);
318 }
319
320 long long
uxlog(r,x)321 uxlog (r, x)
322 double *r, *x;
323 {
324 *r = log( *x );
325 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID);
326 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO | FE_INVALID); return (0);}
327 return (1);
328 }
329
330 long long
uxatan2(r,y,x)331 uxatan2 (r, y, x)
332 double *r, *y, *x;
333 {
334 *r = atan2( *y, *x );
335 fegetexceptflag(&flagp, FE_OVERFLOW | FE_DIVBYZERO);
336 if(flagp != 0) {feclearexcept(FE_OVERFLOW | FE_DIVBYZERO); return (0);}
337 return (1);
338 }
339