Import Upstream version 5c3upstream/5c3

1 files changed, 130 insertions, 38 deletions

diff --git a/subr.c b/subr.c
index f9552c2..5612c1a 100644
--- a/subr.c
+++ b/subr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -798,10 +798,13 @@ SCM scm_big_test(x, nx, xsgn, bigy)
 static char s_logand[] = "logand", s_lognot[] = "lognot",
 	    s_logior[] = "logior", s_logxor[] = "logxor",
 	    s_logtest[] = "logtest", s_logbitp[] = "logbit?",
+            s_copybit[] = "copy-bit",
+            s_copybitfield[] = "copy-bit-field",
 	    s_ash[] = "ash", s_logcount[] = "logcount",
 	    s_intlength[] = "integer-length",
 	    s_intexpt[] = "integer-expt",
-	    s_bitextract[] = "bit-extract";
+	    s_bitfield[] = "bit-field",
+            s_bitif[] = "bitwise-if";
 
 SCM scm_logior(x, y)
      SCM x, y;
@@ -1011,6 +1014,28 @@ SCM scm_logbitp(index, j1)
   return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
 }
 
+SCM scm_copybit(index, j1, bit)
+     SCM 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)));
+#else
+  ASSERT(INUMP(j1), j1, ARG2, s_copybit);
+  ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
+#endif
+  if NFALSEP(bit)
+    return MAKINUM(INUM(j1) | (1L << INUM(index)));
+  else
+    return MAKINUM(INUM(j1) & (~(1L << INUM(index))));
+}
+
 SCM scm_lognot(n)
      SCM n;
 {
@@ -1062,23 +1087,75 @@ SCM scm_ash(n, cnt)
 #endif
 }
 
-SCM scm_bitextract(n, start, end)
+SCM scm_bitfield(n, start, end)
      SCM n, start, end;
 {
-  ASSERT(INUMP(start), start, ARG2, s_bitextract);
-  ASSERT(INUMP(end), end, ARG3, s_bitextract);
+  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_bitextract);
+  ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
 #ifdef BIGDIG
-  if NINUMP(n)
+  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)));
 #else
-  ASSERT(INUMP(n), n, ARG1, s_bitextract);
+  ASSERT(INUMP(n), n, ARG1, s_bitfield);
+  ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
+#endif
+  return MAKINUM((INUM(n)>>start) & ((1L<<(end - start)) - 1));
+}
+
+SCM scm_bitif(mask, n0, n1)
+     SCM mask, n0, n1;
+{
+#ifdef BIGDIG
+  if (NINUMP(mask) || NINUMP(n0) || NINUMP(n1))
+    return scm_logior(scm_logand(mask, n0),
+		      scm_logand(scm_lognot(mask), n1));
+#else
+  ASSERT(INUMP(mask), mask, ARG1, s_bitif);
+  ASSERT(INUMP(n0), n0, ARG2, s_bitif);
+  ASSERT(INUMP(n1), n1, ARG3, s_bitif);
 #endif
-  return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1));
+  return MAKINUM((INUM(mask) & INUM(n0)) | (~(INUM(mask)) & INUM(n1)));
+}
+
+SCM scm_copybitfield(to, start, rest)
+     SCM to, start, rest;
+{
+  long len;
+  SCM end, from;
+#ifndef RECKLESS
+  if (!(NIMP(rest) && CONSP(rest)))
+    wna: wta(UNDEFINED, (char *)WNA, s_copybitfield);
+#endif
+  end = CAR(rest);
+  rest = CDR(rest);
+  ASRTGO(NIMP(rest) && CONSP(rest), wna);
+  from = CAR(rest);
+  ASRTGO(NULLP(CDR(rest)), wna);
+  ASSERT(INUMP(start) && INUM(start)>=0, start, ARG2, s_copybitfield);
+  len = INUM(end) - INUM(start);
+  ASSERT(INUMP(end), end, ARG3, s_copybitfield);
+  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));
+    mask = scm_ash(mask, start);
+    return scm_logior(scm_logand(mask, scm_ash(from, start)), 
+		      scm_logand(scm_lognot(mask), to));
+  }
+#else
+  ASSERT(INUMP(to), to, ARG1, s_copybitfield);
+  ASSERT(INUMP(from), from, ARG4, s_copybitfield);
+  ASSERT(INUM(end) < LONG_BIT - 2, end, OUTOFRANGE, s_copybitfield);
+#endif
+  {
+    long mask = ((1L<<len) - 1)<<INUM(start);
+    return MAKINUM((mask & (INUM(from)<<INUM(start))) | ((~mask) & INUM(to)));
+  }
 }
 
 char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
@@ -1496,20 +1573,19 @@ char	s_make_vector[] = "make-vector";
 SCM make_vector(k, fill)
      SCM k, fill;
 {
-	SCM v;
-	register long i;
-	register SCM *velts;
-	ASSERT(INUMP(k), k, ARG1, s_make_vector);
-	if UNBNDP(fill) fill = UNSPECIFIED;
-	i = INUM(k);
-	NEWCELL(v);
-	DEFER_INTS;
-	SETCHARS(v, must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
-	SETLENGTH(v, i, tc7_vector);
-	velts = VELTS(v);
-	while(--i >= 0) (velts)[i] = fill;
-	ALLOW_INTS;
-	return v;
+  SCM v;
+  register long i;
+  register SCM *velts;
+  ASSERT(INUMP(k), k, ARG1, s_make_vector);
+  if UNBNDP(fill) fill = UNSPECIFIED;
+  i = INUM(k);
+  DEFER_INTS;
+  v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, s_vector);
+  SETLENGTH(v, i, tc7_vector);
+  velts = VELTS(v);
+  while(--i >= 0) (velts)[i] = fill;
+  ALLOW_INTS;
+  return v;
 }
 #ifdef BIGDIG
 char s_bignum[] = "bignum";
@@ -1517,15 +1593,21 @@ SCM mkbig(nlen, sign)
      sizet nlen;
      int sign;
 {
-	SCM v = nlen;
-	if (((v << 16) >> 16) != nlen)
-	  wta(MAKINUM(v), (char *)NALLOC, s_bignum);
-	NEWCELL(v);
-	DEFER_INTS;
-	SETCHARS(v, must_malloc((long)(nlen*sizeof(BIGDIG)), s_bignum));
-	SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
-	ALLOW_INTS;
-	return v;
+  SCM v = nlen;
+  if (((v << 16) >> 16) != nlen)
+    wta(MAKINUM(v), (char *)NALLOC, s_bignum);
+  DEFER_INTS;
+#ifdef NUM_HP
+  if (nlen*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
+    NEWCELL(v);
+    SETCHARS(v, num_hp_alloc(nlen*sizeof(BIGDIG)));
+  }
+  else
+#endif
+    v = must_malloc_cell((long)(nlen*sizeof(BIGDIG)), s_bignum);
+  SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
+  ALLOW_INTS;
+  return v;
 }
 SCM big2inum(b, l)
      SCM b;
@@ -1546,11 +1628,17 @@ SCM adjbig(b, nlen)
      sizet nlen;
 {
   long nsiz = nlen;
-  if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
+  if (((nsiz << 16) >> 16) != nlen)
+    wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
   DEFER_INTS;
-  SETCHARS(b, (BIGDIG *)must_realloc((char *)CHARS(b),
-				    (long)(NUMDIGS(b)*sizeof(BIGDIG)),
-				    (long)(nsiz*sizeof(BIGDIG)), s_adjbig));
+#ifdef NUM_HP
+  SETCHARS(b, (BIGDIG *)num_hp_realloc((char *)CHARS(b),
+				       (long)NUMDIGS(b)*sizeof(BIGDIG),
+				       nsiz*sizeof(BIGDIG), s_adjbig));
+#else
+  must_realloc_cell(b, (long)(NUMDIGS(b)*sizeof(BIGDIG)),
+		    (long)(nsiz*sizeof(BIGDIG)), s_adjbig);
+#endif
   SETNUMDIGS(b, nsiz, TYP16(b));
   ALLOW_INTS;
   return b;
@@ -1613,7 +1701,8 @@ int bigcomp(x, y)
 {
   int xsign = BIGSIGN(x);
   int ysign = BIGSIGN(y);
-  sizet xlen, ylen;
+  long xlen;
+  sizet ylen;
   if (ysign < xsign) return 1;
   if (ysign > xsign) return -1;
   if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
@@ -1979,7 +2068,9 @@ static iproc rpsubrs[] = {
 	{0, 0}};
 
 static iproc subr3s[] = {
-	{s_bitextract, scm_bitextract},
+	{s_bitfield, scm_bitfield},
+	{s_bitif, scm_bitif},
+	{s_copybit, scm_copybit},
 	{s_substring, substring},
 	{s_acons, acons},
 	{s_st_set, st_set},
@@ -2006,4 +2097,5 @@ void init_subrs()
   init_iprocs(lsubrs, tc7_lsubr);
   init_iprocs(asubrs, tc7_asubr);
   init_iprocs(subr3s, tc7_subr_3);
+  make_subr(s_copybitfield, tc7_lsubr_2, scm_copybitfield);
 }