X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=d525b8a38dcd1f6be93f10afc0225e044c566ed4;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=e6ae2979c42237d0cc36df3d7613ec4de3f27a25;hpb=6e73f7320651975ce7cd8e72e2334041b7e80df1;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index e6ae297..d525b8a 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -211,24 +211,6 @@
 
 ;;;; COMPLEXes
 
-(defun upgraded-complex-part-type (spec)
-  #!+sb-doc
-  "Return the element type of the most specialized COMPLEX number type that
-   can hold parts of type SPEC."
-  (cond ((unknown-type-p (specifier-type spec))
-	 (error "undefined type: ~S" spec))
-	((subtypep spec 'single-float)
-	 'single-float)
-	((subtypep spec 'double-float)
-	 'double-float)
-	#!+long-float
-	((subtypep spec 'long-float)
-	 'long-float)
-	((subtypep spec 'rational)
-	 'rational)
-	(t
-	 'real)))
-
 (defun complex (realpart &optional (imagpart 0))
   #!+sb-doc
   "Return a complex number with the specified real and imaginary components."
@@ -283,7 +265,7 @@
     ((complex rational)
      (sb!kernel:%imagpart number))
     (float
-     (float 0 number))
+     (* 0 number))
     (t
      0)))
 
@@ -406,7 +388,7 @@
 		(cond ((eql t1 0) 0)
 		      ((eql g2 1)
 		       (%make-ratio t1 (* t2 dy)))
-		      (T (let* ((nn (truncate t1 g2))
+		      (t (let* ((nn (truncate t1 g2))
 				(t3 (truncate dy g2))
 				(nd (if (eql t2 1) t3 (* t2 t3))))
 			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
@@ -577,7 +559,7 @@
 			  (numerator divisor))))
 	 (values q (- number (* q divisor)))))
       ((fixnum bignum)
-       (values 0 number))
+       (bignum-truncate (make-small-bignum number) divisor))
       ((ratio (or float rational))
        (let ((q (truncate (numerator number)
 			  (* (denominator number) divisor))))
@@ -653,19 +635,21 @@
   (if (eql divisor 1)
       (round number)
       (multiple-value-bind (tru rem) (truncate number divisor)
-	(let ((thresh (/ (abs divisor) 2)))
-	  (cond ((or (> rem thresh)
-		     (and (= rem thresh) (oddp tru)))
-		 (if (minusp divisor)
-		     (values (- tru 1) (+ rem divisor))
-		     (values (+ tru 1) (- rem divisor))))
-		((let ((-thresh (- thresh)))
-		   (or (< rem -thresh)
-		       (and (= rem -thresh) (oddp tru))))
-		 (if (minusp divisor)
-		     (values (+ tru 1) (- rem divisor))
-		     (values (- tru 1) (+ rem divisor))))
-		(t (values tru rem)))))))
+	(if (zerop rem)
+	    (values tru rem)
+	    (let ((thresh (/ (abs divisor) 2)))
+	      (cond ((or (> rem thresh)
+			 (and (= rem thresh) (oddp tru)))
+		     (if (minusp divisor)
+			 (values (- tru 1) (+ rem divisor))
+			 (values (+ tru 1) (- rem divisor))))
+		    ((let ((-thresh (- thresh)))
+		       (or (< rem -thresh)
+			   (and (= rem -thresh) (oddp tru))))
+		     (if (minusp divisor)
+			 (values (+ tru 1) (- rem divisor))
+			 (values (- tru 1) (+ rem divisor))))
+		    (t (values tru rem))))))))
 
 (defun rem (number divisor)
   #!+sb-doc
@@ -685,39 +669,94 @@
 	(+ rem divisor)
 	rem)))
 
-(macrolet ((def (name op doc)
-	     `(defun ,name (number &optional (divisor 1))
-		,doc
-		(multiple-value-bind (res rem) (,op number divisor)
-		  (values (float res (if (floatp rem) rem 1.0)) rem)))))
-  (def ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (def fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (def ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (def fround round
-    "Same as ROUND, but returns first value as a float."))
+(defmacro !define-float-rounding-function (name op doc)
+  `(defun ,name (number &optional (divisor 1))
+    ,doc
+    (multiple-value-bind (res rem) (,op number divisor)
+      (values (float res (if (floatp rem) rem 1.0)) rem))))
+
+(defun ftruncate (number &optional (divisor 1))
+  #!+sb-doc
+  "Same as TRUNCATE, but returns first value as a float."
+  (macrolet ((ftruncate-float (rtype)
+	       `(let* ((float-div (coerce divisor ',rtype))
+		       (res (%unary-ftruncate (/ number float-div))))
+		  (values res
+			  (- number
+			     (* (coerce res ',rtype) float-div))))))
+    (number-dispatch ((number real) (divisor real))
+      (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+       (multiple-value-bind (q r)
+	   (truncate number divisor)
+	 (values (float q) r)))
+      (((foreach single-float double-float #!+long-float long-float)
+	(or rational single-float))
+       (if (eql divisor 1)
+	   (let ((res (%unary-ftruncate number)))
+	     (values res (- number (coerce res '(dispatch-type number)))))
+	   (ftruncate-float (dispatch-type number))))
+      #!+long-float
+      ((long-float (or single-float double-float long-float))
+       (ftruncate-float long-float))
+      #!+long-float
+      (((foreach double-float single-float) long-float)
+       (ftruncate-float long-float))
+      ((double-float (or single-float double-float))
+       (ftruncate-float double-float))
+      ((single-float double-float)
+       (ftruncate-float double-float))
+      (((foreach fixnum bignum ratio)
+	(foreach single-float double-float #!+long-float long-float))
+       (ftruncate-float (dispatch-type divisor))))))
+
+(defun ffloor (number &optional (divisor 1))
+  "Same as FLOOR, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (plusp number)
+                 (minusp number)))
+        (values (1- tru) (+ rem divisor))
+        (values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+  "Same as CEILING, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (minusp number)
+                 (plusp number)))
+        (values (+ tru 1) (- rem divisor))
+        (values tru rem))))
+
+;;; FIXME: this probably needs treatment similar to the use of
+;;; %UNARY-FTRUNCATE for FTRUNCATE.
+(defun fround (number &optional (divisor 1))
+  "Same as ROUND, but returns first value as a float."
+  (multiple-value-bind (res rem)
+      (round number divisor)
+    (values (float res (if (floatp rem) rem 1.0)) rem)))
 
 ;;;; comparisons
 
 (defun = (number &rest more-numbers)
   #!+sb-doc
   "Return T if all of its arguments are numerically equal, NIL otherwise."
+  (the number number)
   (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
+      ((atom nlist) t)
      (declare (list nlist))
      (if (not (= (car nlist) number)) (return nil))))
 
 (defun /= (number &rest more-numbers)
   #!+sb-doc
   "Return T if no two of its arguments are numerically equal, NIL otherwise."
-  (do* ((head number (car nlist))
+  (do* ((head (the number number) (car nlist))
 	(nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) T)
+		  ((atom nl) t)
 	       (declare (list nl))
 	       (if (= head (car nl)) (return nil)))
        (return nil))))
@@ -725,7 +764,7 @@
 (defun < (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
 	(nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
@@ -734,7 +773,7 @@
 (defun > (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
 	(nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
@@ -743,7 +782,7 @@
 (defun <= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
 	(nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
@@ -752,7 +791,7 @@
 (defun >= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
 	(nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
@@ -760,7 +799,8 @@
 
 (defun max (number &rest more-numbers)
   #!+sb-doc
-  "Return the greatest of its arguments."
+  "Return the greatest of its arguments; among EQUALP greatest, return
+the first."
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
@@ -770,7 +810,8 @@
 
 (defun min (number &rest more-numbers)
   #!+sb-doc
-  "Return the least of its arguments."
+  "Return the least of its arguments; among EQUALP least, return
+the first."
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
@@ -778,6 +819,15 @@
      (declare (type real number result))
      (if (< (car nlist) result) (setq result (car nlist)))))
 
+(defconstant most-positive-exactly-single-float-fixnum
+  (min #xffffff most-positive-fixnum))
+(defconstant most-negative-exactly-single-float-fixnum
+  (max #x-ffffff most-negative-fixnum))
+(defconstant most-positive-exactly-double-float-fixnum
+  (min #x1fffffffffffff most-positive-fixnum))
+(defconstant most-negative-exactly-double-float-fixnum
+  (max #x-1fffffffffffff most-negative-fixnum))
+
 (eval-when (:compile-toplevel :execute)
 
 ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
@@ -797,6 +847,40 @@
     #!+long-float
     ((long-float (foreach single-float double-float))
      (,op x (coerce y 'long-float)))
+    ((fixnum (foreach single-float double-float))
+     (if (float-infinity-p y)
+         ,infinite-y-finite-x
+         ;; If the fixnum has an exact float representation, do a
+         ;; float comparison. Otherwise do the slow float -> ratio
+         ;; conversion.
+	 (multiple-value-bind (lo hi)
+	     (case '(dispatch-type y)
+	       ('single-float
+		(values most-negative-exactly-single-float-fixnum
+			most-positive-exactly-single-float-fixnum))
+	       ('double-float
+		(values most-negative-exactly-double-float-fixnum
+			most-positive-exactly-double-float-fixnum)))
+	   (if (<= lo y hi)
+	       (,op (coerce x '(dispatch-type y)) y)
+	       (,op x (rational y))))))
+    (((foreach single-float double-float) fixnum)
+     (if (eql y 0)
+         (,op x (coerce 0 '(dispatch-type x)))
+         (if (float-infinity-p x)
+             ,infinite-x-finite-y
+             ;; Likewise
+	     (multiple-value-bind (lo hi)
+		 (case '(dispatch-type x)
+		   ('single-float
+		    (values most-negative-exactly-single-float-fixnum
+			    most-positive-exactly-single-float-fixnum))
+		   ('double-float
+		    (values most-negative-exactly-double-float-fixnum
+			    most-positive-exactly-double-float-fixnum)))
+	       (if (<= lo y hi)
+		   (,op x (coerce y '(dispatch-type x)))
+		   (,op (rational x) y))))))
     (((foreach single-float double-float) double-float)
      (,op (coerce x 'double-float) y))
     ((double-float single-float)
@@ -953,36 +1037,6 @@
 	(declare (integer result)))
       -1))
 
-(defun lognand (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical AND of integer1 and integer2."
-  (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical OR of integer1 and integer2."
-  (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of (LOGNOT integer1) and integer2."
-  (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of integer1 and (LOGNOT integer2)."
-  (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of (LOGNOT integer1) and integer2."
-  (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of integer1 and (LOGNOT integer2)."
-  (logorc2 integer1 integer2))
-
 (defun lognot (number)
   #!+sb-doc
   "Return the bit-wise logical not of integer."
@@ -990,13 +1044,39 @@
     (fixnum (lognot (truly-the fixnum number)))
     (bignum (bignum-logical-not number))))
 
-(macrolet ((def (name op big-op)
-	     `(defun ,name (x y)
-	       (number-dispatch ((x integer) (y integer))
-		 (bignum-cross-fixnum ,op ,big-op)))))
+(macrolet ((def (name op big-op &optional doc)
+	     `(defun ,name (integer1 integer2)
+		,@(when doc
+		    (list doc))
+		(let ((x integer1)
+		      (y integer2))
+		  (number-dispatch ((x integer) (y integer))
+		    (bignum-cross-fixnum ,op ,big-op))))))
   (def two-arg-and logand bignum-logical-and)
   (def two-arg-ior logior bignum-logical-ior)
-  (def two-arg-xor logxor bignum-logical-xor))
+  (def two-arg-xor logxor bignum-logical-xor)
+  ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
+  ;; call the generic LOGNOT...
+  (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
+  (def lognand lognand 
+       (lambda (x y) (lognot (bignum-logical-and x y))) 
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  (def lognor lognor
+       (lambda (x y) (lognot (bignum-logical-ior x y)))
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
+  (def logandc1 logandc1
+       (lambda (x y) (bignum-logical-and (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
+  (def logandc2 logandc2
+       (lambda (x y) (bignum-logical-and x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
+  (def logorc1 logorc1
+       (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
+  (def logorc2 logorc2
+       (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
 
 (defun logcount (integer)
   #!+sb-doc
@@ -1004,8 +1084,9 @@
   if INTEGER is negative."
   (etypecase integer
     (fixnum
-     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
-					    (lognot most-negative-fixnum)))
+     (logcount (truly-the (integer 0
+				   #.(max sb!xc:most-positive-fixnum
+					  (lognot sb!xc:most-negative-fixnum)))
 			  (if (minusp (truly-the fixnum integer))
 			      (lognot (truly-the fixnum integer))
 			      integer))))
@@ -1020,7 +1101,12 @@
 (defun logbitp (index integer)
   #!+sb-doc
   "Predicate returns T if bit index of integer is a 1."
-  (logbitp index integer))
+  (number-dispatch ((index integer) (integer integer))
+    ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits))
+			 (minusp integer)
+			 (not (zerop (logand integer (ash 1 index))))))
+    ((fixnum bignum) (bignum-logbitp index integer))
+    ((bignum (foreach fixnum bignum)) (minusp integer))))
 
 (defun ash (integer count)
   #!+sb-doc
@@ -1052,7 +1138,8 @@
 
 (defun integer-length (integer)
   #!+sb-doc
-  "Return the number of significant bits in the absolute value of integer."
+  "Return the number of non-sign bits in the twos-complement representation
+  of INTEGER."
   (etypecase integer
     (fixnum
      (integer-length (truly-the fixnum integer)))
@@ -1118,6 +1205,18 @@
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
 	    (logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+  #!+sb-doc
+  "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+  (cond ((zerop size)
+         0)
+        ((logbitp (1- size) integer)
+         (dpb integer (byte size 0) -1))
+        (t
+         (ldb (byte size 0) integer))))
+
 
 ;;;; BOOLE
 
@@ -1193,22 +1292,22 @@
 (defun boole (op integer1 integer2)
   #!+sb-doc
   "Bit-wise boolean function on two integers. Function chosen by OP:
-	0	BOOLE-CLR
-	1	BOOLE-SET
-	2	BOOLE-1
-  	3	BOOLE-2
-	4	BOOLE-C1
-	5	BOOLE-C2
-	6	BOOLE-AND
-	7	BOOLE-IOR
- 	8	BOOLE-XOR
-	9	BOOLE-EQV
-	10	BOOLE-NAND
-	11	BOOLE-NOR
-	12	BOOLE-ANDC1
-	13	BOOLE-ANDC2
-	14	BOOLE-ORC1
-	15	BOOLE-ORC2"
+        0       BOOLE-CLR
+        1       BOOLE-SET
+        2       BOOLE-1
+        3       BOOLE-2
+        4       BOOLE-C1
+        5       BOOLE-C2
+        6       BOOLE-AND
+        7       BOOLE-IOR
+        8       BOOLE-XOR
+        9       BOOLE-EQV
+        10      BOOLE-NAND
+        11      BOOLE-NOR
+        12      BOOLE-ANDC1
+        13      BOOLE-ANDC2
+        14      BOOLE-ORC1
+        15      BOOLE-ORC2"
   (case op
     (0 (boole 0 integer1 integer2))
     (1 (boole 1 integer1 integer2))
@@ -1259,7 +1358,20 @@
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))
-  (* (truncate (max n m) (gcd n m)) (min n m)))
+  (if (or (zerop n) (zerop m))
+      0
+      ;; KLUDGE: I'm going to assume that it was written this way
+      ;; originally for a reason.  However, this is a somewhat
+      ;; complicated way of writing the algorithm in the CLHS page for
+      ;; LCM, and I don't know why.  To be investigated.  -- CSR,
+      ;; 2003-09-11
+      (let ((m (abs m))
+	    (n (abs n)))
+	(multiple-value-bind (max min)
+	    (if (> m n)
+		(values m n)
+		(values n m))
+	  (* (truncate max (gcd n m)) min)))))
 
 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
@@ -1267,8 +1379,8 @@
 ;;; of 0 before the dispatch so that the bignum code doesn't have to worry
 ;;; about "small bignum" zeros.
 (defun two-arg-gcd (u v)
-  (cond ((eql u 0) v)
-	((eql v 0) u)
+  (cond ((eql u 0) (abs v))
+	((eql v 0) (abs u))
 	(t
 	 (number-dispatch ((u integer) (v integer))
 	   ((fixnum fixnum)
@@ -1334,3 +1446,79 @@
   (def minusp "Is this real number strictly negative?")
   (def oddp "Is this integer odd?")
   (def evenp "Is this integer even?"))
+
+;;;; modular functions
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width pattern)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((unsigned-byte ,width) x)
+                         (fixnum (logand x ,pattern))
+                         (bignum (logand x ,pattern)))))
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
+          ;; FIXME: We need to process only "toplevel" functions
+          when (listp infos)
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                   for pattern = (1- (ash 1 width))
+                   do (forms (definition name lambda-list width pattern)))))
+  `(progn ,@(forms)))
+
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((signed-byte ,width) x)
+                         (fixnum (sb!c::mask-signed-field ,width x))
+                         (bignum (sb!c::mask-signed-field ,width x)))))
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+          ;; FIXME: We need to process only "toplevel" functions
+          when (listp infos)
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                   do (forms (definition name lambda-list width)))))
+  `(progn ,@(forms)))
+
+;;; KLUDGE: these out-of-line definitions can't use the modular
+;;; arithmetic, as that is only (currently) defined for constant
+;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
+;;; discussion of this hack.  -- CSR, 2003-10-09
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
+(defun sb!vm::ash-left-mod32 (integer amount)
+  (etypecase integer
+    ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
+    (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
+    (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
+(defun sb!vm::ash-left-mod64 (integer amount)
+  (etypecase integer
+    ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
+    (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
+    (bignum (ldb (byte 64 0)
+		 (ash (logand integer #xffffffffffffffff) amount)))))
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+  (etypecase integer
+    ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+    (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
+
+#!+x86-64
+(defun sb!vm::ash-left-smod61 (integer amount)
+  (etypecase integer
+    ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
+    (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))