(defun = (number &rest more-numbers)
#!+sb-doc
"Return T if all of its arguments are numerically equal, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(the number number)
(do ((nlist more-numbers (cdr nlist)))
((atom nlist) t)
(defun /= (number &rest more-numbers)
#!+sb-doc
"Return T if no two of its arguments are numerically equal, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(do* ((head (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(defun < (number &rest more-numbers)
#!+sb-doc
"Return T if its arguments are in strictly increasing order, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(defun > (number &rest more-numbers)
#!+sb-doc
"Return T if its arguments are in strictly decreasing order, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(defun <= (number &rest more-numbers)
#!+sb-doc
"Return T if arguments are in strictly non-decreasing order, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(defun >= (number &rest more-numbers)
#!+sb-doc
"Return T if arguments are in strictly non-increasing order, NIL otherwise."
+ (declare (dynamic-extent more-numbers))
(do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
#!+sb-doc
"Return the greatest of its arguments; among EQUALP greatest, return
the first."
+ (declare (dynamic-extent more-numbers))
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
#!+sb-doc
"Return the least of its arguments; among EQUALP least, return
the first."
+ (declare (dynamic-extent more-numbers))
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
(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
((complex (or float rational))
(and (= (realpart x) y)
(zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
- #!+sb-doc
- "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
- (or (eq obj1 obj2)
- (if (or (typep obj2 'fixnum)
- (not (typep obj2 'number)))
- nil
- (macrolet ((foo (&rest stuff)
- `(typecase obj2
- ,@(mapcar (lambda (foo)
- (let ((type (car foo))
- (fn (cadr foo)))
- `(,type
- (and (typep obj1 ',type)
- (,fn obj1 obj2)))))
- stuff))))
- (foo
- (single-float eql)
- (double-float eql)
- #!+long-float
- (long-float eql)
- (bignum
- (lambda (x y)
- (zerop (bignum-compare x y))))
- (ratio
- (lambda (x y)
- (and (eql (numerator x) (numerator y))
- (eql (denominator x) (denominator y)))))
- (complex
- (lambda (x y)
- (and (eql (realpart x) (realpart y))
- (eql (imagpart x) (imagpart y))))))))))
\f
;;;; logicals
\f
;;;; GCD and LCM
-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)
#!+sb-doc
"Return the greatest common divisor of the arguments, which must be
integers. Gcd with no arguments is defined to be 0."
- (cond ((null numbers) 0)
- ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (cond ((null integers) 0)
+ ((null (cdr integers)) (abs (the integer (car integers))))
(t
- (do ((gcd (the integer (car numbers))
+ (do ((gcd (the integer (car integers))
(gcd gcd (the integer (car rest))))
- (rest (cdr numbers) (cdr rest)))
+ (rest (cdr integers) (cdr rest)))
((null rest) gcd)
(declare (integer gcd)
(list rest))))))
-(defun lcm (&rest numbers)
+(defun lcm (&rest integers)
#!+sb-doc
"Return the least common multiple of one or more integers. LCM of no
arguments is defined to be 1."
- (cond ((null numbers) 1)
- ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (cond ((null integers) 1)
+ ((null (cdr integers)) (abs (the integer (car integers))))
(t
- (do ((lcm (the integer (car numbers))
+ (do ((lcm (the integer (car integers))
(lcm lcm (the integer (car rest))))
- (rest (cdr numbers) (cdr rest)))
+ (rest (cdr integers) (cdr rest)))
((null rest) lcm)
(declare (integer lcm) (list rest))))))
;; 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
+ ;;
+ ;; It seems to me that this is written this way to avoid
+ ;; unnecessary bignumification of intermediate results.
+ ;; -- TCR, 2008-03-05
(let ((m (abs m))
(n (abs n)))
(multiple-value-bind (max min)
(number-dispatch ((u integer) (v integer))
((fixnum fixnum)
(locally
- (declare (optimize (speed 3) (safety 0)))
+ (declare (optimize (speed 3) (safety 0)))
(do ((k 0 (1+ k))
(u (abs u) (ash u -1))
(v (abs v) (ash v -1)))
(setq temp (- u v))
(when (zerop temp)
(let ((res (ash u k)))
- (declare (type (signed-byte 31) res)
+ (declare (type sb!vm:signed-word res)
(optimize (inhibit-warnings 3)))
(return res))))))
- (declare (type (mod 30) k)
- (type (signed-byte 31) u v)))))
+ (declare (type (mod #.sb!vm:n-word-bits) k)
+ (type sb!vm:signed-word u v)))))
((bignum bignum)
(bignum-gcd u v))
((bignum fixnum)
;;;; modular functions
#.
(collect ((forms))
- (flet ((definition (name lambda-list width pattern)
- `(defun ,name ,lambda-list
- (flet ((prepare-argument (x)
- (declare (integer x))
- (etypecase x
- ((unsigned-byte ,width) x)
- (fixnum (logand x ,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-class-funs sb!c::*unsigned-modular-class*)
- ;; FIXME: We need to process only "toplevel" functions
- 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)
- and lambda-list = (sb!c::modular-fun-info-lambda-list info)
- for pattern = (1- (ash 1 width))
- do (forms (definition name lambda-list width pattern)))))
- `(progn ,@(forms)))
-
-#.
-(collect ((forms))
- (flet ((definition (name lambda-list width)
+ (flet ((unsigned-definition (name lambda-list width)
+ (let ((pattern (1- (ash 1 width))))
+ `(defun ,name ,lambda-list
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((unsigned-byte ,width) x)
+ (fixnum (logand x ,pattern))
+ (bignum (logand x ,pattern)))))
+ (,name ,@(loop for arg in lambda-list
+ collect `(prepare-argument ,arg)))))))
+ (signed-definition (name lambda-list width)
`(defun ,name ,lambda-list
(flet ((prepare-argument (x)
(declare (integer x))
(bignum (sb!c::mask-signed-field ,width x)))))
(,name ,@(loop for arg in lambda-list
collect `(prepare-argument ,arg)))))))
- (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
- ;; FIXME: We need to process only "toplevel" functions
- 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)
- and lambda-list = (sb!c::modular-fun-info-lambda-list info)
- do (forms (definition name lambda-list width)))))
+ (flet ((do-mfuns (class)
+ (loop for infos being each hash-value of (sb!c::modular-class-funs class)
+ ;; FIXME: We need to process only "toplevel" functions
+ 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)
+ and signedp = (sb!c::modular-fun-info-signedp info)
+ and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+ if signedp
+ do (forms (signed-definition name lambda-list width))
+ else
+ do (forms (unsigned-definition name lambda-list width))))))
+ (do-mfuns sb!c::*untagged-unsigned-modular-class*)
+ (do-mfuns sb!c::*untagged-signed-modular-class*)
+ (do-mfuns sb!c::*tagged-modular-class*)))
`(progn ,@(forms)))
;;; KLUDGE: these out-of-line definitions can't use the modular
projects / sbcl.git / blobdiff