diff options
Diffstat (limited to 'subr.c')
| -rw-r--r-- | subr.c | 271 |
1 files changed, 229 insertions, 42 deletions
@@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -476,14 +476,14 @@ SCM modulo(x, y) BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0); } if (!(z = INUM(y))) goto ov; - return divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0); + return divbigint(x, z, z < 0, (BIGSIGN(x) ? (z > 0) : (z < 0)) ? 1 : 0); } if NINUMP(y) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) bady: wta(y, (char *)ARG2, s_modulo); # endif - return (BIGSIGN(y) ? (x>0) : (x<0)) ? sum(x, y) : x; + return (BIGSIGN(y) ? (INUM(x)>0) : (INUM(x)<0)) ? sum(x, y) : x; } #else ASSERT(INUMP(x), x, ARG1, s_modulo); @@ -546,7 +546,8 @@ b3: if (!(1 & (int)t)) goto b3; if (t>0) u = t; else v = -t; - if ((t = u-v)) goto b3; + t = u-v; + if (t) goto b3; u = u*k; getout: if (!POSFIXABLE(u)) @@ -612,6 +613,7 @@ SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn)); SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); +SCM scm_big_ash P((SCM x, long cnt)); SCM scm_copy_big_dec(b, sign) SCM b; @@ -751,7 +753,7 @@ SCM scm_big_and(x, nx, xsgn, bigy, zsgn) } else if (xsgn) do { num += x[i]; - if (num < 0) {zds[i] &= num + BIGRAD; num = -1;} + if (num < 0) {zds[i] &= ~(num + BIGRAD); num = -1;} else {zds[i] &= ~BIGLO(num); num = 0;} } while (++i < nx); else do zds[i] = zds[i] & x[i]; while (++i < nx); @@ -800,6 +802,151 @@ SCM scm_big_test(x, nx, xsgn, bigy) return BOOL_F; } +static SCM scm_copy_big_2scomp P((SCM x, sizet blen, int sign)); +static void scm_2scomp1 P((SCM b)); +static SCM scm_copy_big_2scomp(x, blen, sign) + SCM x; + sizet blen; + int sign; +{ + sizet nres = (blen + BITSPERDIG - 1)/BITSPERDIG; + SCM res; + BIGDIG *rds; + long num = 0; + sizet i; + if INUMP(x) { + long lx = INUM(x); + if (nres < (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG) + nres = (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG; + res = mkbig(nres, sign); + rds = BDIGITS(res); + if (lx < 0) { + lx = -lx; + for (i = 0; i < nres; i++) { + num -= BIGLO(lx); + lx = BIGDN(lx); + if (num < 0) { + rds[i] = num + BIGRAD; + num = -1; + } + else { + rds[i] = num; + num = 0; + } + } + } + else { + for (i = 0; i < nres; i++) { + rds[i] = BIGLO(lx); + lx = BIGDN(lx); + } + } + } + else { + BIGDIG *xds = BDIGITS(x); + sizet nx = NUMDIGS(x); + if (nres < nx) + nres = nx; + res = mkbig(nres, sign); + rds = BDIGITS(res); + if BIGSIGN(x) { + for (i = 0; i < nx; i++) { + num -= xds[i]; + if (num < 0) { + rds[i] = num + BIGRAD; + num = -1; + } + else { + rds[i] = num; + num = 0; + } + } + for (; i < nres; i++) + rds[i] = BIGRAD - 1; + } + else { + for (i = 0; i < nx; i++) + rds[i] = xds[i]; + for (; i < nres; i++) + rds[i] = 0; + } + } + return res; +} +static void scm_2scomp1(b) + SCM b; +{ + long num = 0; + sizet i, n = NUMDIGS(b); + BIGDIG *bds = BDIGITS(b); + for (i = 0; i < n; i++) { + num -= bds[i]; + if (num < 0) { + bds[i] = num + BIGRAD; + num = -1; + } + else { + bds[i] = num; + num = 0; + } + } +} + +SCM scm_big_ash(x, cnt) + SCM x; + long cnt; +{ + SCM res; + BIGDIG *resds; + unsigned long d; + int sign, ishf; + long i, fshf, blen, n; + if INUMP(x) { + blen = LONG_BIT; + sign = INUM(x) < 0 ? 0x0100 : 0; + } + else { + blen = NUMDIGS(x)*BITSPERDIG; + sign = BIGSIGN(x); + } + if (cnt < 0) { + if (blen <= -cnt) return sign ? MAKINUM(-1) : INUM0; + ishf = (-cnt) / BITSPERDIG; + fshf = (-cnt) % BITSPERDIG; + res = scm_copy_big_2scomp(x, blen, sign); + resds = BDIGITS(res); + n = NUMDIGS(res) - ishf - 1; + for (i = 0; i < n; i++) { + d = (resds[i + ishf]>>fshf) | + ((resds[i + ishf + 1])<<(BITSPERDIG - fshf) & (BIGRAD - 1)); + resds[i] = d; + } + d = (resds[i + ishf]>>fshf); + if (sign) d |= ((BIGRAD - 1)<<(BITSPERDIG - fshf) & (BIGRAD - 1)); + resds[i] = d; + n = NUMDIGS(res); + d = sign ? BIGRAD - 1 : 0; + for (i++; i < n; i++) + resds[i] = d; + } + else { + ishf = cnt / BITSPERDIG; + fshf = cnt % BITSPERDIG; + res = scm_copy_big_2scomp(x, blen + cnt, sign); + resds = BDIGITS(res); + for (i = NUMDIGS(res) - 1; i > ishf; i--) { + d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1)) | + ((resds[i - ishf - 1])>>(BITSPERDIG - fshf)); + resds[i] = d; + } + d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1)); + resds[i] = d; + for (i--; i >= 0; i--) + resds[i] = 0; + } + if (sign) scm_2scomp1(res); + return normbig(res); +} #endif static char s_logand[] = "logand", s_lognot[] = "lognot", @@ -996,7 +1143,7 @@ SCM scm_logbitp(index, j1) ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp); #ifdef BIGDIG if NINUMP(j1) { - ASSERT(NIMP(j1) && BIGP(j1), j1, (char *)ARG2, s_logbitp); + ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp); if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F; else if BIGSIGN(j1) { long num = -1; @@ -1015,7 +1162,7 @@ SCM scm_logbitp(index, j1) (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F; } #else - ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp); + ASSERT(INUMP(j1), j1, ARG2, s_logbitp); #endif return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F; } @@ -1025,13 +1172,29 @@ SCM scm_copybit(index, j1, bit) { ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit); #ifdef BIGDIG - if (NINUMP(j1) || (INUM(index) >= LONG_BIT - 3)) - /* This function makes more bignums than it needs to. */ - if NFALSEP(bit) - return scm_logior(j1, scm_ash(MAKINUM(1), index)); - else - return scm_logand(j1, difference(MAKINUM(-1L), - scm_ash(MAKINUM(1), index))); + { + SCM res; + BIGDIG *rds; + sizet i = INUM(index); + int sign; + if (!INUMP(j1)) { + ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit); + sign = BIGSIGN(j1); + ovflow: + res = scm_copy_big_2scomp(j1, i + 1, sign); + rds = BDIGITS(res); + if (NFALSEP(bit)) + rds[i / BITSPERDIG] |= 1 << (i % BITSPERDIG); + else + rds[i / BITSPERDIG] &= ~(1 << (i % BITSPERDIG)); + if (sign) scm_2scomp1(res); + return normbig(res); + } + if (i >= LONG_BIT - 3) { + sign = INUM(j1) < 0 ? 0x0100 : 0; + goto ovflow; + } + } #else ASSERT(INUMP(j1), j1, ARG2, s_copybit); ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit); @@ -1053,37 +1216,61 @@ SCM scm_ash(n, cnt) { SCM res = INUM(n); ASSERT(INUMP(cnt), cnt, ARG2, s_ash); -#ifdef BIGDIG - if(cnt < 0) { - res = scm_intexpt(MAKINUM(2), MAKINUM(-INUM(cnt))); - if NFALSEP(negativep(n)) - return sum(MAKINUM(-1L), lquotient(sum(MAKINUM(1L), n), res)); - else return lquotient(n, res); + cnt = INUM(cnt); + if (INUMP(n)) { + if (cnt < 0) return MAKINUM(SRS(res, -cnt)); + if (cnt >= LONG_BIT) goto ovflow; + res = MAKINUM(res<<cnt); + if (INUM(res)>>cnt != INUM(n)) + goto ovflow; + else + return res; } - else return product(n, scm_intexpt(MAKINUM(2), cnt)); +#ifdef BIGDIG + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_ash); + ovflow: + if (0==cnt) return n; + return scm_big_ash(n, cnt); #else - ASSERT(INUMP(n), n, ARG1, s_ash); - cnt = INUM(cnt); - if (cnt < 0) return MAKINUM(SRS(res, -cnt)); - res = MAKINUM(res<<cnt); - if (INUM(res)>>cnt != INUM(n)) wta(n, (char *)OVFLOW, s_ash); - return res; + ovflow: + wta(n, INUMP(n) ? (char *)OVFLOW : (char *)ARG1, s_ash); + return UNSPECIFIED; /* kill warning */ #endif } SCM scm_bitfield(n, start, end) SCM n, start, end; { + int sign; ASSERT(INUMP(start), start, ARG2, s_bitfield); ASSERT(INUMP(end), end, ARG3, s_bitfield); start = INUM(start); end = INUM(end); ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield); #ifdef BIGDIG - if (NINUMP(n) || end >= LONG_BIT - 2) - return - scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)), - MAKINUM(1L)), - scm_ash(n, MAKINUM(-start))); + if (NINUMP(n)) { + BIGDIG *ds; + sizet i, nd; + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_bitfield); + sign = BIGSIGN(n); + big: + if (sign) n = scm_copy_big_2scomp(n, (sizet)end, 0); + n = scm_big_ash(n, -start); + if (INUMP(n)) { + if (end - start >= LONG_BIT - 2) return n; + return MAKINUM(INUM(n) & ((1L<<(end - start)) - 1)); + } + nd = NUMDIGS(n); + ds = BDIGITS(n); + i = (end - start) / BITSPERDIG; + if (i >= nd) return n; + ds[i] &= ((1 << ((end - start) % BITSPERDIG)) - 1); + for (++i; i < nd; i++) ds[i] = 0; + return normbig(n); + } + if (end >= LONG_BIT - 2) { + sign = INUM(n) < 0; + goto big; + } #else ASSERT(INUMP(n), n, ARG1, s_bitfield); ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield); @@ -1126,7 +1313,7 @@ SCM scm_copybitfield(to, start, rest) ASSERT(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield); #ifdef BIGDIG if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) { - SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L)); + SCM mask = difference(scm_ash(MAKINUM(1L), MAKINUM(len)), MAKINUM(1L)); mask = scm_ash(mask, start); return scm_logior(scm_logand(mask, scm_ash(from, start)), scm_logand(scm_lognot(mask), to)); @@ -1568,7 +1755,7 @@ SCM make_vector(k, fill) if UNBNDP(fill) fill = UNSPECIFIED; i = INUM(k); DEFER_INTS; - v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, + v = must_malloc_cell(i ? i*sizeof(SCM) : 1L, MAKE_LENGTH(i, tc7_vector), s_vector); velts = VELTS(v); while(--i >= 0) (velts)[i] = fill; @@ -1585,7 +1772,7 @@ SCM mkbig(nlen, sign) if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (char *)NALLOC, s_bignum); DEFER_INTS; v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG), - MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos), + MAKE_NUMDIGS(nlen, sign ? tc16_bigneg : tc16_bigpos), s_bignum); ALLOW_INTS; return v; @@ -1600,7 +1787,7 @@ SCM big2inum(b, l) if (TYP16(b)==tc16_bigpos) { if POSFIXABLE(num) return MAKINUM(num); } - else if UNEGFIXABLE(num) return MAKINUM(-num); + else if UNEGFIXABLE(num) return MAKINUM(-(long)num); return b; } char s_adjbig[] = "adjbig"; @@ -1809,7 +1996,7 @@ SCM divbigint(x, z, sgn, mode) sizet nd = NUMDIGS(x); while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z; if (mode && t2) t2 = z - t2; - return MAKINUM(sgn ? -t2 : t2); + return MAKINUM(sgn ? -(long)t2 : t2); } { # ifndef DIGSTOOBIG |