X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=72e8761ef0c4b22fd163473185561ff7a424627d;hb=f3f1143a09fa2e50eec13614cc6b0306b2b11fad;hp=f3adc3bcae6d69661f5acbc65d70ac69d1b27d98;hpb=4b58efcd710097cf7cc9b1a1bed8b0e1bd6eb3b8;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index f3adc3b..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)) @@ -1004,8 +1007,9 @@ if INTEGER is negative." (etypecase integer (fixnum - (logcount (truly-the (integer 0 #.(max most-positive-fixnum - (lognot most-negative-fixnum))) + (logcount (truly-the (integer 0 + #.(max sb!xc:most-positive-fixnum + (lognot sb!xc:most-negative-fixnum))) (if (minusp (truly-the fixnum integer)) (lognot (truly-the fixnum integer)) integer)))) @@ -1020,7 +1024,12 @@ (defun logbitp (index integer) #!+sb-doc "Predicate returns T if bit index of integer is a 1." - (logbitp index integer)) + (number-dispatch ((index integer) (integer integer)) + ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits)) + (minusp integer) + (not (zerop (logand integer (ash 1 index)))))) + ((fixnum bignum) (bignum-logbitp index integer)) + ((bignum (foreach fixnum bignum)) (minusp integer)))) (defun ash (integer count) #!+sb-doc @@ -1259,13 +1268,20 @@ (defun two-arg-lcm (n m) (declare (integer n m)) - (let ((m (abs m)) - (n (abs n))) - (multiple-value-bind (max min) - (if (> m n) - (values m n) - (values n m)) - (* (truncate max (gcd n m)) min)))) + (if (or (zerop n) (zerop m)) + 0 + ;; KLUDGE: I'm going to assume that it was written this way + ;; originally for a reason. However, this is a somewhat + ;; complicated way of writing the algorithm in the CLHS page for + ;; LCM, and I don't know why. To be investigated. -- CSR, + ;; 2003-09-11 + (let ((m (abs m)) + (n (abs n))) + (multiple-value-bind (max min) + (if (> m n) + (values m n) + (values n m)) + (* (truncate max (gcd n m)) min))))) ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly @@ -1345,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) @@ -1367,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)))))