URL
https://opencores.org/ocsvn/eco32/eco32/trunk
Subversion Repositories eco32
[/] [eco32/] [trunk/] [fp/] [implementation/] [arith/] [fp.c] - Rev 46
Go to most recent revision | Compare with Previous | Blame | View Log
#define sign_bit ((unsigned) 0x80000000) \ #define ROUND_OFF 1 #define ROUND_UP 2 #define ROUND_DOWN 3 #define ROUND_NEAR 4 \ #define X_BIT (1<<8) #define Z_BIT (1<<9) #define U_BIT (1<<10) #define O_BIT (1<<11) #define I_BIT (1<<12) #define W_BIT (1<<13) #define V_BIT (1<<14) #define D_BIT (1<<15) #define E_BIT (1<<18) \ #define zero_exponent (-1000) \ #define bignum_prec 157 \ #define magic_offset 2112 #define origin 37 \ #define buf0 (buf+8) #define buf_max (buf+777) \ /*1:*/ #line 32 "./mmix-arith.w" #include <stdio.h> #include <string.h> #include <ctype.h> /*2:*/ #line 49 "./mmix-arith.w" #ifdef __STDC__ #define ARGS(list) list #else #define ARGS(list) () #endif /*:2*/ #line 36 "./mmix-arith.w" typedef enum { false, true } bool; /*3:*/ #line 60 "./mmix-arith.w" typedef unsigned int tetra; typedef struct { tetra h, l; } octa; /*:3*/ #line 38 "./mmix-arith.w" /*36:*/ #line 605 "./mmix-arith.w" typedef enum { zro, num, inf, nan } ftype; /*:36*//*59: */ #line 1110 "./mmix-arith.w" typedef struct { int a; int b; tetra dat[bignum_prec]; } bignum; /*:59*/ #line 39 "./mmix-arith.w" /*4:*/ #line 67 "./mmix-arith.w" octa zero_octa; octa neg_one = { -1, -1 }; octa inf_octa = { 0x7ff00000, 0 }; octa standard_NaN = { 0x7ff80000, 0 }; octa aux; bool overflow; /*:4*//*9: */ #line 174 "./mmix-arith.w" extern octa aux; extern bool overflow; /*:9*//*30: */ #line 464 "./mmix-arith.w" int cur_round; /*:30*//*32: */ #line 528 "./mmix-arith.w" int exceptions; /*:32*//*69: */ #line 1359 "./mmix-arith.w" octa val; char *next_char; /*:69*//*75: */ #line 1432 "./mmix-arith.w" static char buf[785] = "00000000"; /*:75*/ #line 40 "./mmix-arith.w" /*5:*/ #line 78 "./mmix-arith.w" octa oplus ARGS ((octa, octa)); octa oplus (y, z) octa y, z; { octa x; x.h = y.h + z.h; x.l = y.l + z.l; if (x.l < y.l) x.h++; return x; } octa ominus ARGS ((octa, octa)); octa ominus (y, z) octa y, z; { octa x; x.h = y.h - z.h; x.l = y.l - z.l; if (x.l > y.l) x.h--; return x; } /*:5*//*6: */ #line 102 "./mmix-arith.w" octa incr ARGS ((octa, int)); octa incr (y, delta) octa y; int delta; { octa x; x.h = y.h; x.l = y.l + delta; if (delta >= 0) { if (x.l < y.l) x.h++; } else if (x.l > y.l) x.h--; return x; } /*:6*//*7: */ #line 117 "./mmix-arith.w" octa shift_left ARGS ((octa, int)); octa shift_left (y, s) octa y; int s; { while (s >= 32) y.h = y.l, y.l = 0, s -= 32; if (s) { register tetra yhl = y.h << s, ylh = y.l >> (32 - s); y.h = yhl + ylh; y.l <<= s; } return y; } octa shift_right ARGS ((octa, int, int)); octa shift_right (y, s, u) octa y; int s, u; { while (s >= 32) y.l = y.h, y.h = (u ? 0 : -(y.h >> 31)), s -= 32; if (s) { register tetra yhl = y.h << (32 - s), ylh = y.l >> s; y.h = (u ? 0 : (-(y.h >> 31)) << (32 - s)) + (y.h >> s); y.l = yhl + ylh; } return y; } /*:7*//*8: */ #line 150 "./mmix-arith.w" octa omult ARGS ((octa, octa)); octa omult (y, z) octa y, z; { register int i, j, k; tetra u[4], v[4], w[8]; register tetra t; octa acc; /*10:*/ #line 178 "./mmix-arith.w" u[3] = y.h >> 16, u[2] = y.h & 0xffff, u[1] = y.l >> 16, u[0] = y.l & 0xffff; v[3] = z.h >> 16, v[2] = z.h & 0xffff, v[1] = z.l >> 16, v[0] = z.l & 0xffff; /*:10*/ #line 159 "./mmix-arith.w" ; for (j = 0; j < 4; j++) w[j] = 0; for (j = 0; j < 4; j++) if (!v[j]) w[j + 4] = 0; else { for (i = k = 0; i < 4; i++) { t = u[i] * v[j] + w[i + j] + k; w[i + j] = t & 0xffff, k = t >> 16; } w[j + 4] = k; } /*11:*/ #line 182 "./mmix-arith.w" aux.h = (w[7] << 16) + w[6], aux.l = (w[5] << 16) + w[4]; acc.h = (w[3] << 16) + w[2], acc.l = (w[1] << 16) + w[0]; /*:11*/ #line 170 "./mmix-arith.w" ; return acc; } /*:8*//*12: */ #line 191 "./mmix-arith.w" octa signed_omult ARGS ((octa, octa)); octa signed_omult (y, z) octa y, z; { octa acc; acc = omult (y, z); if (y.h & sign_bit) aux = ominus (aux, z); if (z.h & sign_bit) aux = ominus (aux, y); overflow = (aux.h != aux.l || (aux.h ^ (aux.h >> 1) ^ (acc.h & sign_bit))); return acc; } /*:12*//*13: */ #line 215 "./mmix-arith.w" octa odiv ARGS ((octa, octa, octa)); octa odiv (x, y, z) octa x, y, z; { register int i, j, k, n, d; tetra u[8], v[4], q[4], mask, qhat, rhat, vh, vmh; register tetra t; octa acc; /*14:*/ #line 234 "./mmix-arith.w" if (x.h > z.h || (x.h == z.h && x.l >= z.l)) { aux = y; return x; } /*:14*/ #line 224 "./mmix-arith.w" ; /*15:*/ #line 239 "./mmix-arith.w" u[7] = x.h >> 16, u[6] = x.h & 0xffff, u[5] = x.l >> 16, u[4] = x.l & 0xffff; u[3] = y.h >> 16, u[2] = y.h & 0xffff, u[1] = y.l >> 16, u[0] = y.l & 0xffff; v[3] = z.h >> 16, v[2] = z.h & 0xffff, v[1] = z.l >> 16, v[0] = z.l & 0xffff; /*:15*/ #line 225 "./mmix-arith.w" ; /*16:*/ #line 244 "./mmix-arith.w" for (n = 4; v[n - 1] == 0; n--); /*:16*/ #line 226 "./mmix-arith.w" ; /*17:*/ #line 250 "./mmix-arith.w" vh = v[n - 1]; for (d = 0; vh < 0x8000; d++, vh <<= 1); for (j = k = 0; j < n + 4; j++) { t = (u[j] << d) + k; u[j] = t & 0xffff, k = t >> 16; } for (j = k = 0; j < n; j++) { t = (v[j] << d) + k; v[j] = t & 0xffff, k = t >> 16; } vh = v[n - 1]; vmh = (n > 1 ? v[n - 2] : 0); /*:17*/ #line 227 "./mmix-arith.w" ; for (j = 3; j >= 0; j--) /*20: */ #line 276 "./mmix-arith.w" { /*21:*/ #line 284 "./mmix-arith.w" t = (u[j + n] << 16) + u[j + n - 1]; qhat = t / vh, rhat = t - vh * qhat; if (n > 1) while (qhat == 0x10000 || qhat * vmh > (rhat << 16) + u[j + n - 2]) { qhat--, rhat += vh; if (rhat >= 0x10000) break; } /*:21*/ #line 278 "./mmix-arith.w" ; /*22:*/ #line 296 "./mmix-arith.w" for (i = k = 0; i < n; i++) { t = u[i + j] + 0xffff0000 - k - qhat * v[i]; u[i + j] = t & 0xffff, k = 0xffff - (t >> 16); } /*:22*/ #line 279 "./mmix-arith.w" ; /*23:*/ #line 305 "./mmix-arith.w" if (u[j + n] != k) { qhat--; for (i = k = 0; i < n; i++) { t = u[i + j] + v[i] + k; u[i + j] = t & 0xffff, k = t >> 16; } } /*:23*/ #line 280 "./mmix-arith.w" ; q[j] = qhat; } /*:20*/ #line 228 "./mmix-arith.w" ; /*18:*/ #line 264 "./mmix-arith.w" mask = (1 << d) - 1; for (j = 3; j >= n; j--) u[j] = 0; for (k = 0; j >= 0; j--) { t = (k << 16) + u[j]; u[j] = t >> d, k = t & mask; } /*:18*/ #line 229 "./mmix-arith.w" ; /*19:*/ #line 272 "./mmix-arith.w" acc.h = (q[3] << 16) + q[2], acc.l = (q[1] << 16) + q[0]; aux.h = (u[3] << 16) + u[2], aux.l = (u[1] << 16) + u[0]; /*:19*/ #line 230 "./mmix-arith.w" ; return acc; } /*:13*//*24: */ #line 317 "./mmix-arith.w" octa signed_odiv ARGS ((octa, octa)); octa signed_odiv (y, z) octa y, z; { octa yy, zz, q; register int sy, sz; if (y.h & sign_bit) sy = 2, yy = ominus (zero_octa, y); else sy = 0, yy = y; if (z.h & sign_bit) sz = 1, zz = ominus (zero_octa, z); else sz = 0, zz = z; q = odiv (zero_octa, yy, zz); overflow = false; switch (sy + sz) { case 2 + 1: aux = ominus (zero_octa, aux); if (q.h == sign_bit) overflow = true; case 0 + 0: return q; case 2 + 0: if (aux.h || aux.l) aux = ominus (zz, aux); goto negate_q; case 0 + 1: if (aux.h || aux.l) aux = ominus (aux, zz); negate_q:if (aux.h || aux.l) return ominus (neg_one, q); else return ominus (zero_octa, q); } } /*:24*//*25: */ #line 346 "./mmix-arith.w" octa oand ARGS ((octa, octa)); octa oand (y, z) octa y, z; { octa x; x.h = y.h & z.h; x.l = y.l & z.l; return x; } octa oandn ARGS ((octa, octa)); octa oandn (y, z) octa y, z; { octa x; x.h = y.h & ~z.h; x.l = y.l & ~z.l; return x; } octa oxor ARGS ((octa, octa)); octa oxor (y, z) octa y, z; { octa x; x.h = y.h ^ z.h; x.l = y.l ^ z.l; return x; } /*:25*//*26: */ #line 387 "./mmix-arith.w" int count_bits ARGS ((tetra)); int count_bits (x) tetra x; { register int xx = x; xx = xx - ((xx >> 1) & 0x55555555); xx = (xx & 0x33333333) + ((xx >> 2) & 0x33333333); xx = (xx + (xx >> 4)) & 0x0f0f0f0f; xx = xx + (xx >> 8); return (xx + (xx >> 16)) & 0xff; } /*:26*//*27: */ #line 403 "./mmix-arith.w" tetra byte_diff ARGS ((tetra, tetra)); tetra byte_diff (y, z) tetra y, z; { register tetra d = (y & 0x00ff00ff) + 0x01000100 - (z & 0x00ff00ff); register tetra m = d & 0x01000100; register tetra x = d & (m - (m >> 8)); d = ((y >> 8) & 0x00ff00ff) + 0x01000100 - ((z >> 8) & 0x00ff00ff); m = d & 0x01000100; return x + ((d & (m - (m >> 8))) << 8); } /*:27*//*28: */ #line 421 "./mmix-arith.w" tetra wyde_diff ARGS ((tetra, tetra)); tetra wyde_diff (y, z) tetra y, z; { register tetra a = ((y >> 16) - (z >> 16)) & 0x10000; register tetra b = ((y & 0xffff) - (z & 0xffff)) & 0x10000; return y - (z ^ ((y ^ z) & (b - a - (b >> 16)))); } /*:28*//*29: */ #line 434 "./mmix-arith.w" octa bool_mult ARGS ((octa, octa, bool)); octa bool_mult (y, z, xor) octa y, z; bool xor; { octa o, x; register tetra a, b, c; register int k; for (k = 0, o = y, x = zero_octa; o.h || o.l; k++, o = shift_right (o, 8, 1)) if (o.l & 0xff) { a = ((z.h >> k) & 0x01010101) * 0xff; b = ((z.l >> k) & 0x01010101) * 0xff; c = (o.l & 0xff) * 0x01010101; if (xor) x.h ^= a & c, x.l ^= b & c; else x.h |= a & c, x.l |= b & c; } return x; } /*:29*//*31: */ #line 503 "./mmix-arith.w" octa fpack ARGS ((octa, int, char, int)); octa fpack (f, e, s, r) octa f; int e; char s; int r; { octa o; if (e > 0x7fd) e = 0x7ff, o = zero_octa; else { if (e < 0) { if (e < -54) o.h = 0, o.l = 1; else { octa oo; o = shift_right (f, -e, 1); oo = shift_left (o, -e); if (oo.l != f.l || oo.h != f.h) o.l |= 1; } e = 0; } else o = f; } /*33:*/ #line 533 "./mmix-arith.w" if (o.l & 3) exceptions |= X_BIT; switch (r) { case ROUND_DOWN: if (s == '-') o = incr (o, 3); break; case ROUND_UP: if (s != '-') o = incr (o, 3); case ROUND_OFF: break; case ROUND_NEAR: o = incr (o, o.l & 4 ? 2 : 1); break; } o = shift_right (o, 2, 1); o.h += e << 20; if (o.h >= 0x7ff00000) exceptions |= O_BIT + X_BIT; else if (o.h < 0x100000) exceptions |= U_BIT; if (s == '-') o.h |= sign_bit; return o; /*:33*/ #line 525 "./mmix-arith.w" ; } /*:31*//*34: */ #line 551 "./mmix-arith.w" tetra sfpack ARGS ((octa, int, char, int)); tetra sfpack (f, e, s, r) octa f; int e; char s; int r; { register tetra o; if (e > 0x47d) e = 0x47f, o = 0; else { o = shift_left (f, 3).h; if (f.l & 0x1fffffff) o |= 1; if (e < 0x380) { if (e < 0x380 - 25) o = 1; else { register tetra o0, oo; o0 = o; o = o >> (0x380 - e); oo = o << (0x380 - e); if (oo != o0) o |= 1; } e = 0x380; } } /*35:*/ #line 579 "./mmix-arith.w" if (o & 3) exceptions |= X_BIT; switch (r) { case ROUND_DOWN: if (s == '-') o += 3; break; case ROUND_UP: if (s != '-') o += 3; case ROUND_OFF: break; case ROUND_NEAR: o += (o & 4 ? 2 : 1); break; } o = o >> 2; o += (e - 0x380) << 23; if (o >= 0x7f800000) exceptions |= O_BIT + X_BIT; else if (o < 0x100000) exceptions |= U_BIT; if (s == '-') o |= sign_bit; return o; /*:35*/ #line 576 "./mmix-arith.w" ; } /*:34*//*37: */ #line 608 "./mmix-arith.w" ftype funpack ARGS ((octa, octa *, int *, char *)); ftype funpack (x, f, e, s) octa x; octa *f; int *e; char *s; { register int ee; exceptions = 0; *s = (x.h & sign_bit ? '-' : '+'); *f = shift_left (x, 2); f->h &= 0x3fffff; ee = (x.h >> 20) & 0x7ff; if (ee) { *e = ee - 1; f->h |= 0x400000; return (ee < 0x7ff ? num : f->h == 0x400000 && !f->l ? inf : nan); } if (!x.l && !f->h) { *e = zero_exponent; return zro; } do { ee--; *f = shift_left (*f, 1); } while (!(f->h & 0x400000)); *e = ee; return num; } /*:37*//*38: */ #line 634 "./mmix-arith.w" ftype sfunpack ARGS ((tetra, octa *, int *, char *)); ftype sfunpack (x, f, e, s) tetra x; octa *f; int *e; char *s; { register int ee; exceptions = 0; *s = (x & sign_bit ? '-' : '+'); f->h = (x >> 1) & 0x3fffff, f->l = x << 31; ee = (x >> 23) & 0xff; if (ee) { *e = ee + 0x380 - 1; f->h |= 0x400000; return (ee < 0xff ? num : (x & 0x7fffffff) == 0x7f800000 ? inf : nan); } if (!(x & 0x7fffffff)) { *e = zero_exponent; return zro; } do { ee--; *f = shift_left (*f, 1); } while (!(f->h & 0x400000)); *e = ee + 0x380; return num; } /*:38*//*39: */ #line 663 "./mmix-arith.w" octa load_sf ARGS ((tetra)); octa load_sf (z) tetra z; { octa f, x; int e; char s; ftype t; t = sfunpack (z, &f, &e, &s); switch (t) { case zro: x = zero_octa; break; case num: return fpack (f, e, s, ROUND_OFF); case inf: x = inf_octa; break; case nan: x = shift_right (f, 2, 1); x.h |= 0x7ff00000; break; } if (s == '-') x.h |= sign_bit; return x; } /*:39*//*40: */ #line 680 "./mmix-arith.w" tetra store_sf ARGS ((octa)); tetra store_sf (x) octa x; { octa f; tetra z; int e; char s; ftype t; t = funpack (x, &f, &e, &s); switch (t) { case zro: z = 0; break; case num: return sfpack (f, e, s, cur_round); case inf: z = 0x7f800000; break; case nan: if (!(f.h & 0x200000)) { f.h |= 0x200000; exceptions |= I_BIT; } z = 0x7f800000 | (f.h << 1) | (f.l >> 31); break; } if (s == '-') z |= sign_bit; return z; } /*:40*//*41: */ #line 705 "./mmix-arith.w" octa fmult ARGS ((octa, octa)); octa fmult (y, z) octa y, z; { ftype yt, zt; int ye, ze; char ys, zs; octa x, xf, yf, zf; register int xe; register char xs; yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); xs = ys + zs - '+'; switch (4 * yt + zt) { /*42:*/ #line 731 "./mmix-arith.w" case 4 * nan + nan: if (!(y.h & 0x80000)) exceptions |= I_BIT; case 4 * zro + nan: case 4 * num + nan: case 4 * inf + nan: if (!(z.h & 0x80000)) exceptions |= I_BIT, z.h |= 0x80000; return z; case 4 * nan + zro: case 4 * nan + num: case 4 * nan + inf: if (!(y.h & 0x80000)) exceptions |= I_BIT, y.h |= 0x80000; return y; /*:42*/ #line 720 "./mmix-arith.w" ; case 4 * zro + zro: case 4 * zro + num: case 4 * num + zro: x = zero_octa; break; case 4 * num + inf: case 4 * inf + num: case 4 * inf + inf: x = inf_octa; break; case 4 * zro + inf: case 4 * inf + zro: x = standard_NaN; exceptions |= I_BIT; break; case 4 * num + num: /*43: */ #line 740 "./mmix-arith.w" xe = ye + ze - 0x3fd; x = omult (yf, shift_left (zf, 9)); if (aux.h >= 0x400000) xf = aux; else xf = shift_left (aux, 1), xe--; if (x.h || x.l) xf.l |= 1; return fpack (xf, xe, xs, cur_round); /*:43*/ #line 725 "./mmix-arith.w" ; } if (xs == '-') x.h |= sign_bit; return x; } /*:41*//*44: */ #line 748 "./mmix-arith.w" octa fdivide ARGS ((octa, octa)); octa fdivide (y, z) octa y, z; { ftype yt, zt; int ye, ze; char ys, zs; octa x, xf, yf, zf; register int xe; register char xs; yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); xs = ys + zs - '+'; switch (4 * yt + zt) { /*42:*/ #line 731 "./mmix-arith.w" case 4 * nan + nan: if (!(y.h & 0x80000)) exceptions |= I_BIT; case 4 * zro + nan: case 4 * num + nan: case 4 * inf + nan: if (!(z.h & 0x80000)) exceptions |= I_BIT, z.h |= 0x80000; return z; case 4 * nan + zro: case 4 * nan + num: case 4 * nan + inf: if (!(y.h & 0x80000)) exceptions |= I_BIT, y.h |= 0x80000; return y; /*:42*/ #line 763 "./mmix-arith.w" ; case 4 * zro + inf: case 4 * zro + num: case 4 * num + inf: x = zero_octa; break; case 4 * num + zro: exceptions |= Z_BIT; case 4 * inf + num: case 4 * inf + zro: x = inf_octa; break; case 4 * zro + zro: case 4 * inf + inf: x = standard_NaN; exceptions |= I_BIT; break; case 4 * num + num: /*45: */ #line 775 "./mmix-arith.w" xe = ye - ze + 0x3fd; xf = odiv (yf, zero_octa, shift_left (zf, 9)); if (xf.h >= 0x800000) { aux.l |= xf.l & 1; xf = shift_right (xf, 1, 1); xe++; } if (aux.h || aux.l) xf.l |= 1; return fpack (xf, xe, xs, cur_round); /*:45*/ #line 769 "./mmix-arith.w" ; } if (xs == '-') x.h |= sign_bit; return x; } /*:44*//*46: */ #line 790 "./mmix-arith.w" octa fplus ARGS ((octa, octa)); octa fplus (y, z) octa y, z; { ftype yt, zt; int ye, ze; char ys, zs; octa x, xf, yf, zf; register int xe, d; register char xs; yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); switch (4 * yt + zt) { /*42:*/ #line 731 "./mmix-arith.w" case 4 * nan + nan: if (!(y.h & 0x80000)) exceptions |= I_BIT; case 4 * zro + nan: case 4 * num + nan: case 4 * inf + nan: if (!(z.h & 0x80000)) exceptions |= I_BIT, z.h |= 0x80000; return z; case 4 * nan + zro: case 4 * nan + num: case 4 * nan + inf: if (!(y.h & 0x80000)) exceptions |= I_BIT, y.h |= 0x80000; return y; /*:42*/ #line 804 "./mmix-arith.w" ; case 4 * zro + num: return fpack (zf, ze, zs, ROUND_OFF); break; case 4 * num + zro: return fpack (yf, ye, ys, ROUND_OFF); break; case 4 * inf + inf: if (ys != zs) { exceptions |= I_BIT; x = standard_NaN; xs = zs; break; } case 4 * num + inf: case 4 * zro + inf: x = inf_octa; xs = zs; break; case 4 * inf + num: case 4 * inf + zro: x = inf_octa; xs = ys; break; case 4 * num + num: if (y.h != (z.h ^ 0x80000000) || y.l != z.l) /*47:*/ #line 821 "./mmix-arith.w" { octa o, oo; if (ye < ze || (ye == ze && (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l)))) /*48:*/ #line 839 "./mmix-arith.w" { o = yf, yf = zf, zf = o; d = ye, ye = ze, ze = d; d = ys, ys = zs, zs = d; } /*:48*/ #line 824 "./mmix-arith.w" ; d = ye - ze; xs = ys, xe = ye; if (d) /*49: */ #line 859 "./mmix-arith.w" { if (d <= 2) zf = shift_right (zf, d, 1); else if (d > 53) zf.h = 0, zf.l = 1; else { if (ys != zs) d--, xe--, yf = shift_left (yf, 1); o = zf; zf = shift_right (o, d, 1); oo = shift_left (zf, d); if (oo.l != o.l || oo.h != o.h) zf.l |= 1; } } /*:49*/ #line 827 "./mmix-arith.w" ; if (ys == zs) { xf = oplus (yf, zf); if (xf.h >= 0x800000) xe++, d = xf.l & 1, xf = shift_right (xf, 1, 1), xf.l |= d; } else { xf = ominus (yf, zf); if (xf.h >= 0x800000) xe++, d = xf.l & 1, xf = shift_right (xf, 1, 1), xf.l |= d; else while (xf.h < 0x400000) xe--, xf = shift_left (xf, 1); } return fpack (xf, xe, xs, cur_round); } /*:47*/ #line 813 "./mmix-arith.w" ; case 4 * zro + zro: x = zero_octa; xs = (ys == zs ? ys : cur_round == ROUND_DOWN ? '-' : '+'); break; } if (xs == '-') x.h |= sign_bit; return x; } /*:46*//*50: */ #line 883 "./mmix-arith.w" int fepscomp ARGS ((octa, octa, octa, int)); int fepscomp (y, z, e, s) octa y, z, e; int s; { octa yf, zf, ef, o, oo; int ye, ze, ee; char ys, zs, es; register int yt, zt, et, d; et = funpack (e, &ef, &ee, &es); if (es == '-') return 2; switch (et) { case nan: return 2; case inf: ee = 10000; case num: case zro: break; } yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); switch (4 * yt + zt) { case 4 * nan + nan: case 4 * nan + inf: case 4 * nan + num: case 4 * nan + zro: case 4 * inf + nan: case 4 * num + nan: case 4 * zro + nan: return 2; case 4 * inf + inf: return (ys == zs || ee >= 1023); case 4 * inf + num: case 4 * inf + zro: case 4 * num + inf: case 4 * zro + inf: return (s && ee >= 1022); case 4 * zro + zro: return 1; case 4 * zro + num: case 4 * num + zro: if (!s) return 0; case 4 * num + num: break; } /*51:*/ #line 919 "./mmix-arith.w" /*52:*/ #line 934 "./mmix-arith.w" if (ye < 0 && yt != zro) yf = shift_left (y, 2), ye = 0; if (ze < 0 && zt != zro) zf = shift_left (z, 2), ze = 0; /*:52*/ #line 920 "./mmix-arith.w" ; if (ye < ze || (ye == ze && (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l)))) /*48:*/ #line 839 "./mmix-arith.w" { o = yf, yf = zf, zf = o; d = ye, ye = ze, ze = d; d = ys, ys = zs, zs = d; } /*:48*/ #line 922 "./mmix-arith.w" ; if (ze == zero_exponent) ze = ye; d = ye - ze; if (!s) ee -= d; if (ee >= 1023) return 1; /*53:*/ #line 956 "./mmix-arith.w" if (d > 54) o = zero_octa, oo = zf; else o = shift_right (zf, d, 1), oo = shift_left (o, d); if (oo.h != zf.h || oo.l != zf.l) { if (ee < 1020) return 0; o = incr (o, ys == zs ? 0 : 1); } o = (ys == zs ? ominus (yf, o) : oplus (yf, o)); /*:53*/ #line 927 "./mmix-arith.w" ; if (!o.h && !o.l) return 1; if (ee < 968) return 0; if (ee >= 1021) ef = shift_left (ef, ee - 1021); else ef = shift_right (ef, 1021 - ee, 1); return o.h < ef.h || (o.h == ef.h && o.l <= ef.l); /*:51*/ #line 912 "./mmix-arith.w" ; } /*:50*//*54: */ #line 972 "./mmix-arith.w" static void bignum_times_ten ARGS ((bignum *)); static void bignum_dec ARGS ((bignum *, bignum *, tetra)); static int bignum_compare ARGS ((bignum *, bignum *)); void print_float ARGS ((octa)); void print_float (x) octa x; { /*56:*/ #line 1035 "./mmix-arith.w" octa f, g; register int e; register int j, k; /*:56*//*66: */ #line 1281 "./mmix-arith.w" bignum ff, gg; bignum tt; char s[18]; register char *p; /*:66*/ #line 980 "./mmix-arith.w" ; if (x.h & sign_bit) printf ("-"); /*55:*/ #line 1019 "./mmix-arith.w" f = shift_left (x, 1); e = f.h >> 21; f.h &= 0x1fffff; if (!f.h && !f.l) /*57: */ #line 1045 "./mmix-arith.w" { if (!e) { printf ("0."); return; } if (e == 0x7ff) { printf ("Inf"); return; } e--; f.h = 0x3fffff, f.l = 0xffffffff; g.h = 0x400000, g.l = 2; } /*:57*/ #line 1023 "./mmix-arith.w" else { g = incr (f, 1); f = incr (f, -1); if (!e) e = 1; else if (e == 0x7ff) { printf ("NaN"); if (g.h == 0x100000 && g.l == 1) return; e = 0x3ff; } else f.h |= 0x200000, g.h |= 0x200000; } /*:55*/ #line 983 "./mmix-arith.w" ; /*63:*/ #line 1195 "./mmix-arith.w" k = (magic_offset - e) / 28; ff.dat[k - 1] = shift_right (f, magic_offset + 28 - e - 28 * k, 1).l & 0xfffffff; gg.dat[k - 1] = shift_right (g, magic_offset + 28 - e - 28 * k, 1).l & 0xfffffff; ff.dat[k] = shift_right (f, magic_offset - e - 28 * k, 1).l & 0xfffffff; gg.dat[k] = shift_right (g, magic_offset - e - 28 * k, 1).l & 0xfffffff; ff.dat[k + 1] = shift_left (f, e + 28 * k - (magic_offset - 28)).l & 0xfffffff; gg.dat[k + 1] = shift_left (g, e + 28 * k - (magic_offset - 28)).l & 0xfffffff; ff.a = (ff.dat[k - 1] ? k - 1 : k); ff.b = (ff.dat[k + 1] ? k + 1 : k); gg.a = (gg.dat[k - 1] ? k - 1 : k); gg.b = (gg.dat[k + 1] ? k + 1 : k); /*:63*/ #line 984 "./mmix-arith.w" ; /*64:*/ #line 1223 "./mmix-arith.w" if (e > 0x401) /*65: */ #line 1254 "./mmix-arith.w" { register int open = x.l & 1; tt.dat[origin] = 10; tt.a = tt.b = origin; for (e = 1; bignum_compare (&gg, &tt) >= open; e++) bignum_times_ten (&tt); p = s; while (1) { bignum_times_ten (&ff); bignum_times_ten (&gg); for (j = '0'; bignum_compare (&ff, &tt) >= 0; j++) bignum_dec (&ff, &tt, 0x10000000), bignum_dec (&gg, &tt, 0x10000000); if (bignum_compare (&gg, &tt) >= open) break; *p++ = j; if (ff.a == bignum_prec - 1 && !open) goto done; } for (k = j; bignum_compare (&gg, &tt) >= open; k++) bignum_dec (&gg, &tt, 0x10000000); *p++ = (j + 1 + k) >> 1; done:; } /*:65*/ #line 1224 "./mmix-arith.w" else { if (ff.a > origin) ff.dat[origin] = 0; for (e = 1, p = s; gg.a > origin || ff.dat[origin] == gg.dat[origin];) { if (gg.a > origin) e--; else *p++ = ff.dat[origin] + '0', ff.dat[origin] = 0, gg.dat[origin] = 0; bignum_times_ten (&ff); bignum_times_ten (&gg); } *p++ = ((ff.dat[origin] + 1 + gg.dat[origin]) >> 1) + '0'; } *p = '\0'; /*:64*/ #line 985 "./mmix-arith.w" ; /*67:*/ #line 1296 "./mmix-arith.w" if (e > 17 || e < (int) strlen (s) - 17) printf ("%c%s%se%d", s[0], (s[1] ? "." : ""), s + 1, e - 1); else if (e < 0) printf (".%0*d%s", -e, 0, s); else if (strlen (s) >= e) printf ("%.*s.%s", e, s, s + e); else printf ("%s%0*d.", s, e - (int) strlen (s), 0); /*:67*/ #line 986 "./mmix-arith.w" ; } /*:54*//*60: */ #line 1120 "./mmix-arith.w" static void bignum_times_ten (f) bignum *f; { register tetra *p, *q; register tetra x, carry; for (p = &f->dat[f->b], q = &f->dat[f->a], carry = 0; p >= q; p--) { x = *p * 10 + carry; *p = x & 0xfffffff; carry = x >> 28; } *p = carry; if (carry) f->a--; if (f->dat[f->b] == 0 && f->b > f->a) f->b--; } /*:60*//*61: */ #line 1138 "./mmix-arith.w" static int bignum_compare (f, g) bignum *f, *g; { register tetra *p, *pp, *q, *qq; if (f->a != g->a) return f->a > g->a ? -1 : 1; pp = &f->dat[f->b], qq = &g->dat[g->b]; for (p = &f->dat[f->a], q = &g->dat[g->a]; p <= pp; p++, q++) { if (*p != *q) return *p < *q ? -1 : 1; if (q == qq) return p < pp; } return -1; } /*:61*//*62: */ #line 1155 "./mmix-arith.w" static void bignum_dec (f, g, r) bignum *f, *g; tetra r; { register tetra *p, *q, *qq; register int x, borrow; while (g->b > f->b) f->dat[++f->b] = 0; qq = &g->dat[g->a]; for (p = &f->dat[g->b], q = &g->dat[g->b], borrow = 0; q >= qq; p--, q--) { x = *p - *q - borrow; if (x >= 0) borrow = 0, *p = x; else borrow = 1, *p = x + r; } for (; borrow; p--) if (*p) borrow = 0, *p = *p - 1; else *p = r - 1; while (f->dat[f->a] == 0) { if (f->a == f->b) { f->a = f->b = bignum_prec - 1, f->dat[bignum_prec - 1] = 0; return; } f->a++; } while (f->dat[f->b] == 0) f->b--; } /*:62*//*68: */ #line 1340 "./mmix-arith.w" static void bignum_double ARGS ((bignum *)); int scan_const ARGS ((char *)); int scan_const (s) char *s; { /*70:*/ #line 1363 "./mmix-arith.w" register char *p, *q; register bool NaN; int sign; /*:70*//*76: */ #line 1435 "./mmix-arith.w" register char *dec_pt; register int exp; register int zeros; /*:76*//*81: */ #line 1503 "./mmix-arith.w" register int k, x; register char *pp; bignum ff, tt; /*:81*/ #line 1346 "./mmix-arith.w" ; val.h = val.l = 0; p = s; if (*p == '+' || *p == '-') sign = *p++; else sign = '+'; if (strncmp (p, "NaN", 3) == 0) NaN = true, p += 3; else NaN = false; if ((isdigit (*p) && !NaN) || (*p == '.' && isdigit (*(p + 1)))) /*73:*/ #line 1396 "./mmix-arith.w" { for (q = buf0, dec_pt = (char *) 0; isdigit (*p); p++) { val = oplus (val, shift_left (val, 2)); val = incr (shift_left (val, 1), *p - '0'); if (q > buf0 || *p != '0') if (q < buf_max) *q++ = *p; else if (*(q - 1) == '0') *(q - 1) = *p; } if (NaN) *q++ = '1'; if (*p == '.') /*74: */ #line 1415 "./mmix-arith.w" { dec_pt = q; p++; for (zeros = 0; isdigit (*p); p++) if (*p == '0' && q == buf0) zeros++; else if (q < buf_max) *q++ = *p; else if (*(q - 1) == '0') *(q - 1) = *p; } /*:74*/ #line 1406 "./mmix-arith.w" ; next_char = p; if (*p == 'e' && !NaN) /*77: */ #line 1447 "./mmix-arith.w" { register char exp_sign; p++; if (*p == '+' || *p == '-') exp_sign = *p++; else exp_sign = '+'; if (isdigit (*p)) { for (exp = *p++ - '0'; isdigit (*p); p++) if (exp < 1000) exp = 10 * exp + *p - '0'; if (!dec_pt) dec_pt = q, zeros = 0; if (exp_sign == '-') exp = -exp; next_char = p; } } /*:77*/ #line 1408 "./mmix-arith.w" else exp = 0; if (dec_pt) /*78: */ #line 1460 "./mmix-arith.w" { /*79:*/ #line 1477 "./mmix-arith.w" x = buf + 341 + zeros - dec_pt - exp; if (q == buf0 || x >= 1413) { make_it_zero:exp = -99999; goto packit; } if (x < 0) { make_it_infinite:exp = 99999; goto packit; } ff.a = x / 9; for (p = q; p < q + 8; p++) *p = '0'; q = q - 1 - (q + 341 + zeros - dec_pt - exp) % 9; for (p = buf0 - x % 9, k = ff.a; p <= q && k <= 156; p += 9, k++) /*80:*/ #line 1497 "./mmix-arith.w" { for (x = *p - '0', pp = p + 1; pp < p + 9; pp++) x = 10 * x + *pp - '0'; ff.dat[k] = x; } /*:80*/ #line 1490 "./mmix-arith.w" ; ff.b = k - 1; for (x = 0; p <= q; p += 9) if (strncmp (p, "000000000", 9) != 0) x = 1; ff.dat[156] += x; while (ff.dat[ff.b] == 0) ff.b--; /*:79*/ #line 1462 "./mmix-arith.w" ; /*83:*/ #line 1526 "./mmix-arith.w" val = zero_octa; if (ff.a > 36) { for (exp = 0x3fe; ff.a > 36; exp--) bignum_double (&ff); for (k = 54; k; k--) { if (ff.dat[36]) { if (k >= 32) val.h |= 1 << (k - 32); else val.l |= 1 << k; ff.dat[36] = 0; if (ff.b == 36) break; } bignum_double (&ff); } } else { tt.a = tt.b = 36, tt.dat[36] = 2; for (exp = 0x3fe; bignum_compare (&ff, &tt) >= 0; exp++) bignum_double (&tt); for (k = 54; k; k--) { bignum_double (&ff); if (bignum_compare (&ff, &tt) >= 0) { if (k >= 32) val.h |= 1 << (k - 32); else val.l |= 1 << k; bignum_dec (&ff, &tt, 1000000000); if (ff.a == bignum_prec - 1) break; } } } if (k == 0) val.l |= 1; /*:83*/ #line 1463 "./mmix-arith.w" ; packit: /*84: */ #line 1559 "./mmix-arith.w" val = fpack (val, exp, sign, ROUND_NEAR); if (NaN) { if ((val.h & 0x7fffffff) == 0x40000000) val.h |= 0x7fffffff, val.l = 0xffffffff; else if ((val.h & 0x7fffffff) == 0x3ff00000 && !val.l) val.h |= 0x40000000, val.l = 1; else val.h |= 0x40000000; } /*:84*/ #line 1464 "./mmix-arith.w" ; return 1; } /*:78*/ #line 1410 "./mmix-arith.w" ; if (sign == '-') val = ominus (zero_octa, val); return 0; } /*:73*/ #line 1353 "./mmix-arith.w" ; if (NaN) /*71: */ #line 1368 "./mmix-arith.w" { next_char = p; val.h = 0x600000, exp = 0x3fe; goto packit; } /*:71*/ #line 1354 "./mmix-arith.w" ; if (strncmp (p, "Inf", 3) == 0) /*72: */ #line 1375 "./mmix-arith.w" { next_char = p + 3; goto make_it_infinite; } /*:72*/ #line 1355 "./mmix-arith.w" ; no_const_found:next_char = s; return -1; } /*:68*//*82: */ #line 1511 "./mmix-arith.w" static void bignum_double (f) bignum *f; { register tetra *p, *q; register int x, carry; for (p = &f->dat[f->b], q = &f->dat[f->a], carry = 0; p >= q; p--) { x = *p + *p + carry; if (x >= 1000000000) carry = 1, *p = x - 1000000000; else carry = 0, *p = x; } *p = carry; if (carry) f->a--; if (f->dat[f->b] == 0 && f->b > f->a) f->b--; } /*:82*//*85: */ #line 1575 "./mmix-arith.w" int fcomp ARGS ((octa, octa)); int fcomp (y, z) octa y, z; { ftype yt, zt; int ye, ze; char ys, zs; octa yf, zf; register int x; yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); switch (4 * yt + zt) { case 4 * nan + nan: case 4 * zro + nan: case 4 * num + nan: case 4 * inf + nan: case 4 * nan + zro: case 4 * nan + num: case 4 * nan + inf: return 2; case 4 * zro + zro: return 0; case 4 * zro + num: case 4 * num + zro: case 4 * zro + inf: case 4 * inf + zro: case 4 * num + num: case 4 * num + inf: case 4 * inf + num: case 4 * inf + inf: if (ys != zs) x = 1; else if (y.h > z.h) x = 1; else if (y.h < z.h) x = -1; else if (y.l > z.l) x = 1; else if (y.l < z.l) x = -1; else return 0; break; } return (ys == '-' ? -x : x); } /*:85*//*86: */ #line 1608 "./mmix-arith.w" octa fintegerize ARGS ((octa, int)); octa fintegerize (z, r) octa z; int r; { ftype zt; int ze; char zs; octa xf, zf; zt = funpack (z, &zf, &ze, &zs); if (!r) r = cur_round; switch (zt) { case nan: if (!(z.h & 0x80000)) { exceptions |= I_BIT; z.h |= 0x80000; } case inf: case zro: return z; case num: /*87: */ #line 1627 "./mmix-arith.w" if (ze >= 1074) return fpack (zf, ze, zs, ROUND_OFF); if (ze <= 1020) xf.h = 0, xf.l = 1; else { octa oo; xf = shift_right (zf, 1074 - ze, 1); oo = shift_left (xf, 1074 - ze); if (oo.l != zf.l || oo.h != zf.h) xf.l |= 1; } switch (r) { case ROUND_DOWN: if (zs == '-') xf = incr (xf, 3); break; case ROUND_UP: if (zs != '-') xf = incr (xf, 3); case ROUND_OFF: break; case ROUND_NEAR: xf = incr (xf, xf.l & 4 ? 2 : 1); break; } xf.l &= 0xfffffffc; if (ze >= 1022) return fpack (shift_left (xf, 1074 - ze), ze, zs, ROUND_OFF); if (xf.l) xf.h = 0x3ff00000, xf.l = 0; if (zs == '-') xf.h |= sign_bit; return xf; /*:87*/ #line 1623 "./mmix-arith.w" ; } } /*:86*//*88: */ #line 1650 "./mmix-arith.w" octa fixit ARGS ((octa, int)); octa fixit (z, r) octa z; int r; { ftype zt; int ze; char zs; octa zf, o; zt = funpack (z, &zf, &ze, &zs); if (!r) r = cur_round; switch (zt) { case nan: case inf: exceptions |= I_BIT; return z; case zro: return zero_octa; case num: if (funpack (fintegerize (z, r), &zf, &ze, &zs) == zro) return zero_octa; if (ze <= 1076) o = shift_right (zf, 1076 - ze, 1); else { if (ze > 1085 || (ze == 1085 && (zf.h > 0x400000 || (zf.h == 0x400000 && (zf.l || zs != '-'))))) exceptions |= W_BIT; if (ze >= 1140) return zero_octa; o = shift_left (zf, ze - 1076); } return (zs == '-' ? ominus (zero_octa, o) : o); } } /*:88*//*89: */ #line 1681 "./mmix-arith.w" octa floatit ARGS ((octa, int, int, int)); octa floatit (z, r, u, p) octa z; int r; int u; int p; { int e; char s; register int t; exceptions = 0; if (!z.h && !z.l) return zero_octa; if (!r) r = cur_round; if (!u && (z.h & sign_bit)) s = '-', z = ominus (zero_octa, z); else s = '+'; e = 1076; while (z.h < 0x400000) e--, z = shift_left (z, 1); while (z.h >= 0x800000) { e++; t = z.l & 1; z = shift_right (z, 1, 1); z.l |= t; } if (p) /*90: */ #line 1707 "./mmix-arith.w" { register int ex; register tetra t; t = sfpack (z, e, s, r); ex = exceptions; sfunpack (t, &z, &e, &s); exceptions = ex; } /*:90*/ #line 1703 "./mmix-arith.w" ; return fpack (z, e, s, r); } /*:89*//*91: */ #line 1718 "./mmix-arith.w" octa froot ARGS ((octa, int)); octa froot (z, r) octa z; int r; { ftype zt; int ze; char zs; octa x, xf, rf, zf; register int xe, k; if (!r) r = cur_round; zt = funpack (z, &zf, &ze, &zs); if (zs == '-' && zt != zro) exceptions |= I_BIT, x = standard_NaN; else switch (zt) { case nan: if (!(z.h & 0x80000)) exceptions |= I_BIT, z.h |= 0x80000; return z; case inf: case zro: x = z; break; case num: /*92: */ #line 1750 "./mmix-arith.w" xf.h = 0, xf.l = 2; xe = (ze + 0x3fe) >> 1; if (ze & 1) zf = shift_left (zf, 1); rf.h = 0, rf.l = (zf.h >> 22) - 1; for (k = 53; k; k--) { rf = shift_left (rf, 2); xf = shift_left (xf, 1); if (k >= 43) rf = incr (rf, (zf.h >> (2 * (k - 43))) & 3); else if (k >= 27) rf = incr (rf, (zf.l >> (2 * (k - 27))) & 3); if ((rf.l > xf.l && rf.h >= xf.h) || rf.h > xf.h) { xf.l++; rf = ominus (rf, xf); xf.l++; } } if (rf.h || rf.l) xf.l++; return fpack (xf, xe, '+', r); /*:92*/ #line 1736 "./mmix-arith.w" ; } if (zs == '-') x.h |= sign_bit; return x; } /*:91*//*93: */ #line 1774 "./mmix-arith.w" octa fremstep ARGS ((octa, octa, int)); octa fremstep (y, z, delta) octa y, z; int delta; { ftype yt, zt; int ye, ze; char xs, ys, zs; octa x, xf, yf, zf; register int xe, thresh, odd; yt = funpack (y, &yf, &ye, &ys); zt = funpack (z, &zf, &ze, &zs); switch (4 * yt + zt) { /*42:*/ #line 731 "./mmix-arith.w" case 4 * nan + nan: if (!(y.h & 0x80000)) exceptions |= I_BIT; case 4 * zro + nan: case 4 * num + nan: case 4 * inf + nan: if (!(z.h & 0x80000)) exceptions |= I_BIT, z.h |= 0x80000; return z; case 4 * nan + zro: case 4 * nan + num: case 4 * nan + inf: if (!(y.h & 0x80000)) exceptions |= I_BIT, y.h |= 0x80000; return y; /*:42*/ #line 1788 "./mmix-arith.w" ; case 4 * zro + zro: case 4 * num + zro: case 4 * inf + zro: case 4 * inf + num: case 4 * inf + inf: x = standard_NaN; exceptions |= I_BIT; break; case 4 * zro + num: case 4 * zro + inf: case 4 * num + inf: return y; case 4 * num + num: /*94: */ #line 1809 "./mmix-arith.w" odd = 0; thresh = ye - delta; if (thresh < ze) thresh = ze; while (ye >= thresh) /*95: */ #line 1830 "./mmix-arith.w" { if (yf.h == zf.h && yf.l == zf.l) goto zero_out; if (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l)) { if (ye == ze) goto try_complement; ye--, yf = shift_left (yf, 1); } yf = ominus (yf, zf); if (ye == ze) odd = 1; while (yf.h < 0x400000) ye--, yf = shift_left (yf, 1); } /*:95*/ #line 1815 "./mmix-arith.w" ; if (ye >= ze) { exceptions |= E_BIT; return fpack (yf, ye, ys, ROUND_OFF); } if (ye < ze - 1) return fpack (yf, ye, ys, ROUND_OFF); yf = shift_right (yf, 1, 1); try_complement:xf = ominus (zf, yf), xe = ze, xs = '+' + '-' - ys; if (xf.h > yf.h || (xf.h == yf.h && (xf.l > yf.l || (xf.l == yf.l && !odd)))) xf = yf, xs = ys; while (xf.h < 0x400000) xe--, xf = shift_left (xf, 1); return fpack (xf, xe, xs, ROUND_OFF); /*:94*/ #line 1793 "./mmix-arith.w" ; zero_out:x = zero_octa; } if (ys == '-') x.h |= sign_bit; return x; } /*:93*/ #line 41 "./mmix-arith.w" /*:1*/
Go to most recent revision | Compare with Previous | Blame | View Log