(defun realpart (number)
#!+sb-doc
"Extract the real part of a number."
- (typecase number
+ (etypecase number
#!+long-float
((complex long-float)
(truly-the long-float (realpart number)))
(truly-the single-float (realpart number)))
((complex rational)
(sb!kernel:%realpart number))
- (t
+ (number
number)))
(defun imagpart (number)
#!+sb-doc
"Extract the imaginary part of a number."
- (typecase number
+ (etypecase number
#!+long-float
((complex long-float)
(truly-the long-float (imagpart number)))
(sb!kernel:%imagpart number))
(float
(* 0 number))
- (t
+ (number
0)))
(defun conjugate (number)
#!+sb-doc
"Return the complex conjugate of NUMBER. For non-complex numbers, this is
an identity."
+ (declare (type number number))
(if (complexp number)
(complex (realpart number) (- (imagpart number)))
number))
(,op (imagpart x) (imagpart y))))
(((foreach bignum fixnum ratio single-float double-float
#!+long-float long-float) complex)
- (complex (,op x (realpart y)) (,op (imagpart y))))
+ (complex (,op x (realpart y)) (,op 0 (imagpart y))))
((complex (or rational float))
- (complex (,op (realpart x) y) (imagpart x)))
+ (complex (,op (realpart x) y) (,op (imagpart x) 0)))
(((foreach fixnum bignum) ratio)
(let* ((dy (denominator y))
(defun = (number &rest more-numbers)
#!+sb-doc
"Return T if all of its arguments are numerically equal, NIL otherwise."
- (declare (dynamic-extent more-numbers))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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))
+ (declare (truly-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
\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)
;;;; 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)))))
- `(progn ,@(forms)))
+ (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 ,@(sort (forms) #'string< :key #'cadr)))
;;; KLUDGE: these out-of-line definitions can't use the modular
;;; arithmetic, as that is only (currently) defined for constant
projects / sbcl.git / blobdiff