Import Upstream version 5d6upstream/5d6

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