From 853afafe8be6613be426667ad037ab5b0437c638 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 23 Apr 1997 05:41:03 +0000
Subject: [PATCH] Add new primitive INTEGER-SHIFT-LEFT.  This is a very fast
 way to multiply an integer by a power of two.

---
 v7/src/microcode/artutl.c | 46 +++++++++++++++------
 v7/src/microcode/bignum.c | 86 ++++++++++++++++++++++++++++++++++++++-
 v7/src/microcode/bignum.h |  7 +++-
 v7/src/microcode/extern.h |  4 +-
 v7/src/microcode/intprm.c | 15 ++++++-
 5 files changed, 141 insertions(+), 17 deletions(-)

diff --git a/v7/src/microcode/artutl.c b/v7/src/microcode/artutl.c
index 68aebb9b2..218fd71b0 100644
--- a/v7/src/microcode/artutl.c
+++ b/v7/src/microcode/artutl.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: artutl.c,v 1.13 1997/04/22 22:42:16 cph Exp $
+$Id: artutl.c,v 1.14 1997/04/23 05:40:18 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -462,24 +462,46 @@ DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
   }
 }
 
+static unsigned long
+DEFUN (unsigned_long_length_in_bits, (n), unsigned long n)
+{
+  unsigned long result = 0;
+  while (n > 0)
+    {
+      result += 1;
+      n >>= 1;
+    }
+  return (result);
+}
+
 SCHEME_OBJECT
 DEFUN (integer_length_in_bits, (n), SCHEME_OBJECT n)
 {
   if (FIXNUM_P (n))
     {
       long n1 = (FIXNUM_TO_LONG (n));
-      unsigned long n2 = ((n1 < 0) ? (- n1) : n1);
-      unsigned long result = ((sizeof (unsigned long)) * CHAR_BIT);
-      unsigned long m = (1 << (result - 1));
-      while (result > 0)
-	{
-	  if (n2 >= m)
-	    break;
-	  result -= 1;
-	  m >>= 1;
-	}
-      return (LONG_TO_UNSIGNED_FIXNUM (result));
+      return (LONG_TO_UNSIGNED_FIXNUM
+	      (unsigned_long_length_in_bits ((n1 < 0) ? (- n1) : n1)));
     }
   else
     return (bignum_length_in_bits (n));
 }
+
+SCHEME_OBJECT
+DEFUN (integer_shift_left, (n, m), SCHEME_OBJECT n AND unsigned long m)
+{
+  if ((m == 0) || (!integer_positive_p (n)))
+    return (n);
+  if (FIXNUM_P (n))
+    {
+      unsigned long n1 = (UNSIGNED_FIXNUM_TO_LONG (n));
+      unsigned long ln = (unsigned_long_length_in_bits (n1));
+      unsigned long lr = (ln + m);
+      return
+	((lr <= FIXNUM_LENGTH)
+	 ? (LONG_TO_UNSIGNED_FIXNUM (n1 << m))
+	 : (unsigned_long_to_shifted_bignum (n1, m, 0)));
+    }
+  else
+    return (bignum_shift_left (n, m));
+}
diff --git a/v7/src/microcode/bignum.c b/v7/src/microcode/bignum.c
index 3b16c106f..8a7c70d20 100644
--- a/v7/src/microcode/bignum.c
+++ b/v7/src/microcode/bignum.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: bignum.c,v 9.43 1997/01/02 05:21:30 cph Exp $
+$Id: bignum.c,v 9.44 1997/04/23 05:40:11 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -664,6 +664,90 @@ DEFUN_VOID (bignum_length_upper_limit)
 }
 
 bignum_type
+DEFUN (bignum_shift_left, (n, m), bignum_type n AND unsigned long m)
+{
+  unsigned long ln = (BIGNUM_LENGTH (n));
+  unsigned long delta = 0;
+  if (m == 0)
+    return (n);
+  {
+    bignum_digit_type digit = (BIGNUM_REF (n, (ln - 1)));
+    while (digit > 0)
+      {
+	delta += 1;
+	digit >>= 1;
+      }
+  }
+  {
+    unsigned long zeroes = (m / BIGNUM_DIGIT_LENGTH);
+    unsigned long shift = (m % BIGNUM_DIGIT_LENGTH);
+    unsigned long ln2
+      = (((ln - 1) + ((delta + m) / BIGNUM_DIGIT_LENGTH))
+	 + (((delta + m) % BIGNUM_DIGIT_LENGTH) != 0));
+    bignum_type result = (bignum_allocate (ln2, (BIGNUM_NEGATIVE_P (n))));
+    bignum_digit_type * scan_n = (BIGNUM_START_PTR (n));
+    bignum_digit_type * end_n = (scan_n + ln);
+    bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+    while ((zeroes--) > 0)
+      (*scan_result++) = 0;
+    if (shift == 0)
+      while (scan_n < end_n)
+	(*scan_result++) = (*scan_n++);
+    else
+      {
+	unsigned long temp = 0;
+	while (scan_n < end_n)
+	  {
+	    bignum_digit_type digit = (*scan_n++);
+	    (*scan_result++) = (((digit << shift) & BIGNUM_DIGIT_MASK) | temp);
+	    temp = (digit >> (BIGNUM_DIGIT_LENGTH - shift));
+	  }
+	if (temp != 0)
+	  (*scan_result) = temp;
+      }
+    return (result);
+  }
+}
+
+bignum_type
+DEFUN (unsigned_long_to_shifted_bignum, (n, m, sign),
+       unsigned long n AND
+       unsigned long m AND
+       int sign)
+{
+  unsigned long delta = 0;
+  if (n == 0)
+    return (BIGNUM_ZERO ());
+  {
+    unsigned long n1 = n;
+    while (n1 > 0)
+      {
+	delta += 1;
+	n1 >>= 1;
+      }
+  }
+  {
+    unsigned long zeroes = (m / BIGNUM_DIGIT_LENGTH);
+    unsigned long shift = (m % BIGNUM_DIGIT_LENGTH);
+    unsigned long ln
+      = (((delta + m) / BIGNUM_DIGIT_LENGTH)
+	 + (((delta + m) % BIGNUM_DIGIT_LENGTH) != 0));
+    bignum_type result = (bignum_allocate (ln, sign));
+    bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+    while ((zeroes--) > 0)
+      (*scan_result++) = 0;
+    (*scan_result++) = ((n << shift) & BIGNUM_DIGIT_MASK);
+    n >>= (BIGNUM_DIGIT_LENGTH - shift);
+    while (n > 0)
+      {
+	(*scan_result++) = (n & BIGNUM_DIGIT_MASK);
+	n >>= BIGNUM_DIGIT_LENGTH;
+      }
+    return (result);
+  }
+}
+
+bignum_type
 DEFUN (digit_stream_to_bignum,
        (n_digits, producer, context, radix, negative_p),
        fast unsigned int n_digits
diff --git a/v7/src/microcode/bignum.h b/v7/src/microcode/bignum.h
index a25a24b48..d4d47ad5d 100644
--- a/v7/src/microcode/bignum.h
+++ b/v7/src/microcode/bignum.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: bignum.h,v 9.29 1996/10/02 18:57:02 cph Exp $
+$Id: bignum.h,v 9.30 1997/04/23 05:40:26 cph Exp $
 
-Copyright (c) 1989-96 Massachusetts Institute of Technology
+Copyright (c) 1989-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -92,6 +92,9 @@ extern int EXFUN
 			   int twos_complement_p));
 extern bignum_type EXFUN (bignum_length_in_bits, (bignum_type));
 extern bignum_type EXFUN (bignum_length_upper_limit, (void));
+extern bignum_type EXFUN (bignum_shift_left, (bignum_type, unsigned long));
+extern bignum_type EXFUN
+  (unsigned_long_to_shifted_bignum, (unsigned long, unsigned long, int));
 extern bignum_type EXFUN
   (digit_stream_to_bignum,
    (unsigned int n_digits,
diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h
index 29e540923..a0a33b486 100644
--- a/v7/src/microcode/extern.h
+++ b/v7/src/microcode/extern.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: extern.h,v 9.54 1997/04/22 22:42:25 cph Exp $
+$Id: extern.h,v 9.55 1997/04/23 05:41:03 cph Exp $
 
 Copyright (c) 1987-97 Massachusetts Institute of Technology
 
@@ -206,6 +206,8 @@ extern Boolean EXFUN (integer_divide,
 extern SCHEME_OBJECT EXFUN (integer_quotient, (SCHEME_OBJECT, SCHEME_OBJECT));
 extern SCHEME_OBJECT EXFUN (integer_remainder, (SCHEME_OBJECT, SCHEME_OBJECT));
 extern SCHEME_OBJECT EXFUN (integer_length_in_bits, (SCHEME_OBJECT));
+extern SCHEME_OBJECT EXFUN
+  (integer_shift_left, (SCHEME_OBJECT, SCHEME_OBJECT));
 
 /* Character utilities */
 extern long EXFUN (char_downcase, (long));
diff --git a/v7/src/microcode/intprm.c b/v7/src/microcode/intprm.c
index c7c15900c..1b0e64355 100644
--- a/v7/src/microcode/intprm.c
+++ b/v7/src/microcode/intprm.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: intprm.c,v 1.5 1997/04/22 22:42:41 cph Exp $
+$Id: intprm.c,v 1.6 1997/04/23 05:40:32 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -180,3 +180,16 @@ DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0)
     PRIMITIVE_RETURN (SHARP_F);
   }
 }
+
+DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  Set_Time_Zone (Zone_Math);
+  CHECK_ARG (1, INTEGER_P);
+  {
+    SCHEME_OBJECT n = (ARG_REF (1));
+    if (integer_negative_p (n))
+      error_bad_range_arg (1);
+    PRIMITIVE_RETURN (integer_shift_left (n, (arg_ulong_integer (2))));
+  }
+}
-- 
2.25.1