(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
;; conversion.
(multiple-value-bind (lo hi)
(case '(dispatch-type y)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
;; Likewise
(multiple-value-bind (lo hi)
(case '(dispatch-type x)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
((fixnum bignum)
(bignum-gcd (make-small-bignum u) v))))))
\f
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
+;;;; from Robert Smith
(defun isqrt (n)
#!+sb-doc
"Return the root of the nearest integer less than n which is a perfect
square."
- (declare (type unsigned-byte n) (values unsigned-byte))
- ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
- (if (and (fixnump n) (<= n 24))
- (cond ((> n 15) 4)
- ((> n 8) 3)
- ((> n 3) 2)
- ((> n 0) 1)
- (t 0))
- (let* ((n-len-quarter (ash (integer-length n) -2))
- (n-half (ash n (- (ash n-len-quarter 1))))
- (n-half-isqrt (isqrt n-half))
- (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
- (loop
- (let ((iterated-value
- (ash (+ init-value (truncate n init-value)) -1)))
- (unless (< iterated-value init-value)
- (return init-value))
- (setq init-value iterated-value))))))
+ (declare (type unsigned-byte n))
+ (cond
+ ((> n 24)
+ (let* ((n-fourth-size (ash (1- (integer-length n)) -2))
+ (n-significant-half (ash n (- (ash n-fourth-size 1))))
+ (n-significant-half-isqrt (isqrt n-significant-half))
+ (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size))
+ (qr (multiple-value-list (floor n zeroth-iteration)))
+ (first-iteration (ash (+ zeroth-iteration (first qr)) -1)))
+ (cond ((oddp (first qr))
+ first-iteration)
+ ((> (expt (- first-iteration zeroth-iteration) 2) (second qr))
+ (1- first-iteration))
+ (t
+ first-iteration))))
+ ((> n 15) 4)
+ ((> n 8) 3)
+ ((> n 3) 2)
+ ((> n 0) 1)
+ ((= n 0) 0)))
\f
;;;; miscellaneous number predicates
(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