Import Upstream version 5d2upstream/5d2

1 files changed, 26 insertions, 50 deletions

diff --git a/subr.c b/subr.c
index 5612c1a..e55bf17 100644
--- a/subr.c
+++ b/subr.c
@@ -1,18 +1,18 @@
 /* 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
  * the Free Software Foundation; either version 2, or (at your option)
  * any later version.
- * 
+ *
  * This program is distributed in the hope that it will be useful,
  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU General Public License for more details.
- * 
+ *
  * You should have received a copy of the GNU General Public License
  * along with this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * 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.
@@ -36,7 +36,7 @@
  *
  * If you write modifications of your own for GUILE, it is your choice
  * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  
+ * If you do not wish that, delete this exception notice.
  */
 
 /* "subr.c" integer and other Scheme procedures
@@ -268,6 +268,13 @@ SCM assoc(x, alist)
 	return BOOL_F;
 }
 
+extern long tc16_promise;
+SCM promisep(x)
+     SCM x;
+{
+       return NIMP(x) && (TYP16(x)==tc16_promise) ? BOOL_T : BOOL_F;
+}
+
 SCM symbolp(x)
      SCM x;
 {
@@ -802,7 +809,6 @@ static char s_logand[] = "logand", s_lognot[] = "lognot",
             s_copybitfield[] = "copy-bit-field",
 	    s_ash[] = "ash", s_logcount[] = "logcount",
 	    s_intlength[] = "integer-length",
-	    s_intexpt[] = "integer-expt",
 	    s_bitfield[] = "bit-field",
             s_bitif[] = "bitwise-if";
 
@@ -1042,28 +1048,6 @@ SCM scm_lognot(n)
   return difference(MAKINUM(-1L), n);
 }
 
-SCM scm_intexpt(z1, z2)
-     SCM z1, z2;
-{
-  SCM acc = MAKINUM(1L);
-#ifdef BIGDIG
-  if (INUM0==z1 || acc==z1) return z1;
-  else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
-#endif
-  ASSERT(INUMP(z2), z2, ARG2, s_intexpt);
-  z2 = INUM(z2);
-  if (z2 < 0) {
-    z2 = -z2;
-    z1 = divide(z1, UNDEFINED);
-  }
-  while(1) {
-    if (0==z2) return acc;
-    if (1==z2) return product(acc, z1);
-    if (z2 & 1) acc = product(acc, z1);
-    z1 = product(z1, z1);
-    z2 >>= 1;
-  }
-}
 SCM scm_ash(n, cnt)
      SCM n, cnt;
 {
@@ -1144,7 +1128,7 @@ SCM scm_copybitfield(to, start, rest)
   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)), 
+    return scm_logior(scm_logand(mask, scm_ash(from, start)),
 		      scm_logand(scm_lognot(mask), to));
   }
 #else
@@ -1576,12 +1560,16 @@ SCM make_vector(k, fill)
   SCM v;
   register long i;
   register SCM *velts;
+#ifdef SHORT_SIZET
   ASSERT(INUMP(k), k, ARG1, s_make_vector);
+#else
+  ASSERT(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector);
+#endif
   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);
+  v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L,
+		       MAKE_LENGTH(i, tc7_vector), s_vector);
   velts = VELTS(v);
   while(--i >= 0) (velts)[i] = fill;
   ALLOW_INTS;
@@ -1593,19 +1581,12 @@ SCM mkbig(nlen, sign)
      sizet nlen;
      int sign;
 {
-  SCM v = nlen;
-  if (((v << 16) >> 16) != nlen)
-    wta(MAKINUM(v), (char *)NALLOC, s_bignum);
+  SCM v;
+  if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (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);
+  v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG),
+		       MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos),
+		       s_bignum);
   ALLOW_INTS;
   return v;
 }
@@ -1631,14 +1612,8 @@ SCM adjbig(b, nlen)
   if (((nsiz << 16) >> 16) != nlen)
     wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
   DEFER_INTS;
-#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;
@@ -1954,6 +1929,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes)
 #endif
 
 static iproc cxrs[] = {
+	{"cr", 0},
 	{"car", 0}, {"cdr", 0},
 	{"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0},
 	{"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0},
@@ -1997,6 +1973,7 @@ static iproc subr1s[] = {
 	{"vector?", vectorp},
 	{s_ve_length, vector_length},
 	{"procedure?", procedurep},
+	{"promise?", promisep},
 	{0, 0}};
 
 static char s_acons[] = "acons";
@@ -2015,7 +1992,6 @@ static iproc subr2s[] = {
 	{s_logtest, scm_logtest},
 	{s_logbitp, scm_logbitp},
 	{s_ash, scm_ash},
-	{s_intexpt, scm_intexpt},
 	{s_st_ref, st_ref},
 	{"string<=?", st_leqp},
 	{"string-ci<=?", stci_leqp},