summaryrefslogtreecommitdiffstats
path: root/subr.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitdeda2c0fd8689349fea2a900199a76ff7ecb319e (patch)
treec9726d54a0806a9b0c75e6c82db8692aea0053cf /subr.c
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz
scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'subr.c')
-rw-r--r--subr.c271
1 files changed, 229 insertions, 42 deletions
diff --git a/subr.c b/subr.c
index e55bf17..e8b5176 100644
--- a/subr.c
+++ b/subr.c
@@ -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