X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fnumbers.lisp;h=2b26643bc3cf141f5a186c3f5fec04fbca0297b5;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=16929b1c2b1642a6b09106e585e9451b49fb0e58;hpb=cb79d726de3e18c660f84c58a43f00d22b459037;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 16929b1..2b26643 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -819,6 +819,15 @@ the first."
      (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
@@ -838,6 +847,40 @@ the first."
     #!+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)
@@ -1095,7 +1138,8 @@ the first."
 
 (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)))
@@ -1453,13 +1497,13 @@ the first."
 ;;; 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
-#!-alpha
+#!+#.(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)))))
-#!+alpha
+#!+#.(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)))
@@ -1472,3 +1516,9 @@ the first."
   (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)))))