(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))
(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))
(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))
(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))
(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))
(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))
(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."
(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
#.
(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)
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)))))
projects / sbcl.git / blobdiff