1 /* j/e/rd.c
2 **
3 */
4 #include "all.h"
5 #include <softfloat.h>
6 
7 #define DOUBNAN 0x7ff8000000000000
8 
9   union doub {
10     float64_t d;
11     c3_d c;
12   };
13 
14 /* functions
15 */
16   static inline c3_t
_nan_test(float64_t a)17   _nan_test(float64_t a)
18   {
19     return !f64_eq(a, a);
20   }
21 
22   static inline float64_t
_nan_unify(float64_t a)23   _nan_unify(float64_t a)
24   {
25     if ( _nan_test(a) )
26     {
27       *(c3_d*)(&a) = DOUBNAN;
28     }
29     return a;
30   }
31 
32   static inline void
_set_rounding(c3_w a)33   _set_rounding(c3_w a)
34   {
35     switch ( a )
36     {
37     default:
38       u3m_bail(c3__fail);
39       break;
40     case c3__n:
41       softfloat_roundingMode = softfloat_round_near_even;
42       break;
43     case c3__z:
44       softfloat_roundingMode = softfloat_round_minMag;
45       break;
46     case c3__u:
47       softfloat_roundingMode = softfloat_round_max;
48       break;
49     case c3__d:
50       softfloat_roundingMode = softfloat_round_min;
51       break;
52     }
53   }
54 
55 /* add
56 */
57   u3_noun
u3qer_add(u3_atom a,u3_atom b,u3_atom r)58   u3qer_add(u3_atom a,
59             u3_atom b,
60             u3_atom r)
61   {
62     union doub c, d, e;
63     _set_rounding(r);
64     c.c = u3r_chub(0, a);
65     d.c = u3r_chub(0, b);
66     e.d = _nan_unify(f64_add(c.d, d.d));
67 
68     return u3i_chubs(1, &e.c);
69   }
70 
71   u3_noun
u3wer_add(u3_noun cor)72   u3wer_add(u3_noun cor)
73   {
74     u3_noun a, b;
75 
76     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
77          c3n == u3ud(a) ||
78          c3n == u3ud(b) )
79     {
80       return u3m_bail(c3__exit);
81     }
82     else {
83       return u3qer_add(a, b, u3x_at(30, cor));
84     }
85   }
86 
87 /* sub
88 */
89   u3_noun
u3qer_sub(u3_atom a,u3_atom b,u3_atom r)90   u3qer_sub(u3_atom a,
91             u3_atom b,
92             u3_atom r)
93   {
94     union doub c, d, e;
95     _set_rounding(r);
96     c.c = u3r_chub(0, a);
97     d.c = u3r_chub(0, b);
98     e.d = _nan_unify(f64_sub(c.d, d.d));
99 
100     return u3i_chubs(1, &e.c);
101   }
102 
103   u3_noun
u3wer_sub(u3_noun cor)104   u3wer_sub(u3_noun cor)
105   {
106     u3_noun a, b;
107 
108     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
109          c3n == u3ud(a) ||
110          c3n == u3ud(b) )
111     {
112       return u3m_bail(c3__exit);
113     }
114     else {
115       return u3qer_sub(a, b, u3x_at(30, cor));
116     }
117   }
118 
119 /* mul
120 */
121   u3_noun
u3qer_mul(u3_atom a,u3_atom b,u3_atom r)122   u3qer_mul(u3_atom a,
123             u3_atom b,
124             u3_atom r)
125   {
126     union doub c, d, e;
127     _set_rounding(r);
128     c.c = u3r_chub(0, a);
129     d.c = u3r_chub(0, b);
130     e.d = _nan_unify(f64_mul(c.d, d.d));
131 
132     return u3i_chubs(1, &e.c);
133   }
134 
135   u3_noun
u3wer_mul(u3_noun cor)136   u3wer_mul(u3_noun cor)
137   {
138     u3_noun a, b;
139 
140     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
141          c3n == u3ud(a) ||
142          c3n == u3ud(b) )
143     {
144       return u3m_bail(c3__exit);
145     }
146     else {
147       return u3qer_mul(a, b, u3x_at(30, cor));
148     }
149   }
150 
151 /* div
152 */
153   u3_noun
u3qer_div(u3_atom a,u3_atom b,u3_atom r)154   u3qer_div(u3_atom a,
155             u3_atom b,
156             u3_atom r)
157   {
158     union doub c, d, e;
159     _set_rounding(r);
160     c.c = u3r_chub(0, a);
161     d.c = u3r_chub(0, b);
162     e.d = _nan_unify(f64_div(c.d, d.d));
163 
164     return u3i_chubs(1, &e.c);
165   }
166 
167   u3_noun
u3wer_div(u3_noun cor)168   u3wer_div(u3_noun cor)
169   {
170     u3_noun a, b;
171 
172     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
173          c3n == u3ud(a) ||
174          c3n == u3ud(b) )
175     {
176       return u3m_bail(c3__exit);
177     }
178     else {
179       return u3qer_div(a, b, u3x_at(30, cor));
180     }
181   }
182 
183 /* sqt
184 */
185   u3_noun
u3qer_sqt(u3_atom a,u3_atom r)186   u3qer_sqt(u3_atom a,
187             u3_atom r)
188   {
189     union doub c, d;
190     _set_rounding(r);
191     c.c = u3r_chub(0, a);
192     d.d = _nan_unify(f64_sqrt(c.d));
193 
194     return u3i_chubs(1, &d.c);
195   }
196 
197   u3_noun
u3wer_sqt(u3_noun cor)198   u3wer_sqt(u3_noun cor)
199   {
200     u3_noun a;
201 
202     if ( c3n == (a = u3r_at(u3x_sam, cor)) ||
203          c3n == u3ud(a) )
204     {
205       return u3m_bail(c3__exit);
206     }
207     else {
208       return u3qer_sqt(a, u3x_at(30, cor));
209     }
210   }
211 
212 /* fma
213 */
214   u3_noun
u3qer_fma(u3_atom a,u3_atom b,u3_atom c,u3_atom r)215   u3qer_fma(u3_atom a,
216             u3_atom b,
217             u3_atom c,
218             u3_atom r)
219   {
220     union doub d, e, f, g;
221     _set_rounding(r);
222     d.c = u3r_chub(0, a);
223     e.c = u3r_chub(0, b);
224     f.c = u3r_chub(0, c);
225     g.d = _nan_unify(f64_mulAdd(d.d, e.d, f.d));
226 
227     return u3i_chubs(1, &g.c);
228   }
229 
230   u3_noun
u3wer_fma(u3_noun cor)231   u3wer_fma(u3_noun cor)
232   {
233     u3_noun a, b, c;
234 
235     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_6, &b, u3x_sam_7, &c, 0) ||
236          c3n == u3ud(a) ||
237          c3n == u3ud(b) ||
238          c3n == u3ud(c) )
239     {
240       return u3m_bail(c3__exit);
241     }
242     else {
243       return u3qer_fma(a, b, c, u3x_at(30, cor));
244     }
245   }
246 
247 /* lth
248 */
249   u3_noun
u3qer_lth(u3_atom a,u3_atom b)250   u3qer_lth(u3_atom a,
251             u3_atom b)
252   {
253     union doub c, d;
254     c.c = u3r_chub(0, a);
255     d.c = u3r_chub(0, b);
256 
257     return __(f64_lt(c.d, d.d));
258   }
259 
260   u3_noun
u3wer_lth(u3_noun cor)261   u3wer_lth(u3_noun cor)
262   {
263     u3_noun a, b;
264 
265     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
266          c3n == u3ud(a) ||
267          c3n == u3ud(b) )
268     {
269       return u3m_bail(c3__exit);
270     }
271     else {
272       return u3qer_lth(a, b);
273     }
274   }
275 
276 /* lte
277 */
278   u3_noun
u3qer_lte(u3_atom a,u3_atom b)279   u3qer_lte(u3_atom a,
280             u3_atom b)
281   {
282     union doub c, d;
283     c.c = u3r_chub(0, a);
284     d.c = u3r_chub(0, b);
285 
286     return __(f64_le(c.d, d.d));
287   }
288 
289   u3_noun
u3wer_lte(u3_noun cor)290   u3wer_lte(u3_noun cor)
291   {
292     u3_noun a, b;
293 
294     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
295          c3n == u3ud(a) ||
296          c3n == u3ud(b) )
297     {
298       return u3m_bail(c3__exit);
299     }
300     else {
301       return u3qer_lte(a, b);
302     }
303   }
304 
305 /* equ
306 */
307   u3_noun
u3qer_equ(u3_atom a,u3_atom b)308   u3qer_equ(u3_atom a,
309             u3_atom b)
310   {
311     union doub c, d;
312     c.c = u3r_chub(0, a);
313     d.c = u3r_chub(0, b);
314 
315     return __(f64_eq(c.d, d.d));
316   }
317 
318   u3_noun
u3wer_equ(u3_noun cor)319   u3wer_equ(u3_noun cor)
320   {
321     u3_noun a, b;
322 
323     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
324          c3n == u3ud(a) ||
325          c3n == u3ud(b) )
326     {
327       return u3m_bail(c3__exit);
328     }
329     else {
330       return u3qer_equ(a, b);
331     }
332   }
333 
334 /* gte
335 */
336   u3_noun
u3qer_gte(u3_atom a,u3_atom b)337   u3qer_gte(u3_atom a,
338             u3_atom b)
339   {
340     union doub c, d;
341     c.c = u3r_chub(0, a);
342     d.c = u3r_chub(0, b);
343 
344     return __(f64_le(d.d, c.d));
345   }
346 
347   u3_noun
u3wer_gte(u3_noun cor)348   u3wer_gte(u3_noun cor)
349   {
350     u3_noun a, b;
351 
352     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
353          c3n == u3ud(a) ||
354          c3n == u3ud(b) )
355     {
356       return u3m_bail(c3__exit);
357     }
358     else {
359       return u3qer_gte(a, b);
360     }
361   }
362 
363 /* gth
364 */
365   u3_noun
u3qer_gth(u3_atom a,u3_atom b)366   u3qer_gth(u3_atom a,
367             u3_atom b)
368   {
369     union doub c, d;
370     c.c = u3r_chub(0, a);
371     d.c = u3r_chub(0, b);
372 
373     return __(f64_lt(d.d, c.d));
374   }
375 
376   u3_noun
u3wer_gth(u3_noun cor)377   u3wer_gth(u3_noun cor)
378   {
379     u3_noun a, b;
380 
381     if ( c3n == u3r_mean(cor, u3x_sam_2, &a, u3x_sam_3, &b, 0) ||
382          c3n == u3ud(a) ||
383          c3n == u3ud(b) )
384     {
385       return u3m_bail(c3__exit);
386     }
387     else {
388       return u3qer_gth(a, b);
389     }
390   }
391