0.8.10.9:

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 283cd4a..fc7af0f 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -211,25 +211,6 @@
 \f
 ;;;; COMPLEXes
 
-(defun upgraded-complex-part-type (spec &optional environment)
-  #!+sb-doc
-  "Return the element type of the most specialized COMPLEX number type that
-   can hold parts of type SPEC."
-  (declare (ignore environment))
-  (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."
@@ -708,6 +689,7 @@
 (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)
      (declare (list nlist))
@@ -716,7 +698,7 @@
 (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))
@@ -729,7 +711,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))
@@ -738,7 +720,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))
@@ -747,7 +729,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))
@@ -756,7 +738,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))
@@ -764,7 +746,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))
@@ -774,7 +757,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))
@@ -1358,20 +1342,18 @@
 #.
 (collect ((forms))
   (flet ((definition (name lambda-list width pattern)
-           (assert (sb!xc:subtypep `(unsigned-byte ,width)
-                                   'bignum-element-type))
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
                        (etypecase x
                          ((unsigned-byte ,width) x)
                          (fixnum (logand x ,pattern))
-                         (bignum (logand (%bignum-ref x 0) ,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-funs*
           ;; FIXME: We need to process only "toplevel" functions
-          unless (eq infos :good)
+          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)
@@ -1379,3 +1361,21 @@
                    for pattern = (1- (ash 1 width))
                    do (forms (definition name lambda-list width pattern)))))
   `(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
+#!-alpha
+(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
+(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)))))