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