(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)
(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)))
+ `(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