X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=72e8761ef0c4b22fd163473185561ff7a424627d;hb=fab1ba8d4e92ecb5d496577fc205675218911b1d;hp=751b6f2c40b683405e58cafee738d9f762ff3ef3;hpb=6cc71ab8ffad49f43895ad0a1df6885c81876687;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 751b6f2..72e8761 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -708,6 +708,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 +717,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 +730,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 +739,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 +748,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 +757,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 +765,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 +776,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))
@@ -957,36 +960,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."
@@ -994,13 +967,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
@@ -1362,21 +1361,18 @@
 #.
 (collect ((forms))
   (flet ((definition (name lambda-list width pattern)
-           ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
-           ;;                      'BIGNUM-ELEMENT-TYPE)
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
                        (etypecase x
                          ((unsigned-byte ,width) x)
-                         (bignum-element-type (logand x ,pattern))
                          (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)
@@ -1384,3 +1380,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)))))