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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 16929b1..d525b8a 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -388,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))))))))))))
@@ -744,7 +744,7 @@
   "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))))
 
@@ -756,7 +756,7 @@
        ((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))))
@@ -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)))))