0.9.0.21:

[sbcl.git] / src / code / numbers.lisp

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 16929b1..d525b8a 100644 (file)
--- 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)))))