(denominator number))
\f
;;;; arithmetic operations
+;;;;
+;;;; IMPORTANT NOTE: Accessing &REST arguments with NTH is actually extremely
+;;;; efficient in SBCL, as is taking their LENGTH -- so this code is very
+;;;; clever instead of being charmingly naive. Please check that "obvious"
+;;;; improvements don't actually ruin performance.
+;;;;
+;;;; (Granted that the difference between very clever and charmingly naivve
+;;;; can sometimes be sliced exceedingly thing...)
(macrolet ((define-arith (op init doc)
#!-sb-doc (declare (ignore doc))
- `(define-more-fun ,op (&rest numbers)
+ `(defun ,op (&rest numbers)
#!+sb-doc
,doc
- (if (more-p)
- (let ((result (more-arg 0)))
- ;; to signal TYPE-ERROR when exactly 1 arg of wrong type:
- (declare (type number result))
- (do-more (arg 1)
- (setf result (,op result arg)))
- result)
+ (if numbers
+ (do ((result (nth 0 numbers) (,op result (nth i numbers)))
+ (i 1 (1+ i)))
+ ((>= i (length numbers))
+ result)
+ (declare (number result)))
,init))))
(define-arith + 0
"Return the sum of its arguments. With no args, returns 0.")
(define-arith * 1
"Return the product of its arguments. With no args, returns 1."))
-(define-more-fun - (number &rest more-numbers)
+(defun - (number &rest more-numbers)
#!+sb-doc
"Subtract the second and all subsequent arguments from the first;
or with one argument, negate the first argument."
- (if (more-p)
+ (if more-numbers
(let ((result number))
- (do-more (arg)
- (setf result (- result arg)))
- result)
+ (dotimes (i (length more-numbers) result)
+ (setf result (- result (nth i more-numbers)))))
(- number)))
-(define-more-fun / (number &rest more-numbers)
+(defun / (number &rest more-numbers)
#!+sb-doc
"Divide the first argument by each of the following arguments, in turn.
With one argument, return reciprocal."
- (if (more-p)
+ (if more-numbers
(let ((result number))
- (do-more (arg)
- (setf result (/ result arg)))
- result)
+ (dotimes (i (length more-numbers) result)
+ (setf result (/ result (nth i more-numbers)))))
(/ number)))
(defun 1+ (number)
\f
;;;; comparisons
-(define-more-fun = (number &rest more-numbers)
+(defun = (number &rest more-numbers)
#!+sb-doc
"Return T if all of its arguments are numerically equal, NIL otherwise."
(declare (number number))
- (do-more (arg)
- (unless (= number arg)
- (return-from = nil)))
- t)
+ (dotimes (i (length more-numbers) t)
+ (unless (= number (nth i more-numbers))
+ (return nil))))
-(define-more-fun /= (number &rest more-numbers)
+(defun /= (number &rest more-numbers)
#!+sb-doc
"Return T if no two of its arguments are numerically equal, NIL otherwise."
(declare (number number))
- (do-more (arg)
- (when (= number arg)
- (return-from /= nil)))
- (dotimes (start (1- (more-count)))
- (let ((head (more-arg start)))
- (do-more (arg (1+ start))
- (when (= head arg)
- (return-from /= nil)))))
- t)
+ (if more-numbers
+ (do ((n number (nth i more-numbers))
+ (i 0 (1+ i)))
+ ((>= i (length more-numbers))
+ t)
+ (do ((j i (1+ j)))
+ ((>= j (length more-numbers)))
+ (when (= n (nth j more-numbers))
+ (return-from /= nil))))
+ t))
(macrolet ((def (op doc)
#!-sb-doc (declare (ignore doc))
- `(define-more-fun ,op (number &rest more-numbers)
+ `(defun ,op (number &rest more-numbers)
#!+sb-doc ,doc
(let ((n number))
(declare (number n))
- (do-more (arg)
- (if (,op n arg)
+ (dotimes (i (length more-numbers) t)
+ (let ((arg (nth i more-numbers)))
+ (if (,op n arg)
(setf n arg)
- (return-from ,op nil)))
- t))))
+ (return-from ,op nil))))))))
(def < "Return T if its arguments are in strictly increasing order, NIL otherwise.")
(def > "Return T if its arguments are in strictly decreasing order, NIL otherwise.")
(def <= "Return T if arguments are in strictly non-decreasing order, NIL otherwise.")
(def >= "Return T if arguments are in strictly non-increasing order, NIL otherwise."))
-(define-more-fun max (number &rest more-numbers)
+(defun max (number &rest more-numbers)
#!+sb-doc
"Return the greatest of its arguments; among EQUALP greatest, return
the first."
(let ((n number))
(declare (number n))
- (do-more (arg)
- (when (> arg n)
- (setf n arg)))
- n))
+ (dotimes (i (length more-numbers) n)
+ (let ((arg (nth i more-numbers)))
+ (when (> arg n)
+ (setf n arg))))))
-(define-more-fun min (number &rest more-numbers)
+(defun min (number &rest more-numbers)
#!+sb-doc
"Return the least of its arguments; among EQUALP least, return
the first."
(let ((n number))
(declare (number n))
- (do-more (arg)
- (when (< arg n)
- (setf n arg)))
- n))
+ (dotimes (i (length more-numbers) n)
+ (let ((arg (nth i more-numbers)))
+ (when (< arg n)
+ (setf n arg))))))
(eval-when (:compile-toplevel :execute)
(macrolet ((def (op init doc)
#!-sb-doc (declare (ignore doc))
- `(define-more-fun ,op (&rest integers)
+ `(defun ,op (&rest integers)
#!+sb-doc ,doc
- (if (more-p)
- (let ((result (more-arg 0)))
- (declare (integer result))
- (do-more (arg 1)
- (setf result (,op result arg)))
- result)
+ (if integers
+ (do ((result (nth 0 integers) (,op result (nth i integers)))
+ (i 1 (1+ i)))
+ ((>= i (length integers))
+ result)
+ (declare (integer result)))
,init))))
(def logior 0 "Return the bit-wise or of its arguments. Args must be integers.")
(def logxor 0 "Return the bit-wise exclusive or of its arguments. Args must be integers.")
(deposit-field newbyte bytespec integer))
(defun %ldb (size posn integer)
+ (declare (type bit-index size posn))
(logand (ash integer (- posn))
(1- (ash 1 size))))
(defun %mask-field (size posn integer)
+ (declare (type bit-index size posn))
(logand integer (ash (1- (ash 1 size)) posn)))
(defun %dpb (newbyte size posn integer)
+ (declare (type bit-index size posn))
(let ((mask (1- (ash 1 size))))
(logior (logand integer (lognot (ash mask posn)))
(ash (logand newbyte mask) posn))))
(defun %deposit-field (newbyte size posn integer)
+ (declare (type bit-index size posn))
(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand newbyte mask)
(logand integer (lognot mask)))))
\f
;;;; GCD and LCM
-(define-more-fun gcd (&rest integers)
+(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."
- (case (more-count)
+ integers. GCD with no arguments is defined to be 0."
+ (case (length integers)
(0 0)
- (1 (abs (the integer (more-arg 0))))
+ (1 (abs (the integer (nth 0 integers))))
(otherwise
- (let ((gcd (more-arg 0)))
- (declare (integer gcd))
- (do-more (arg 1)
- (setf gcd (gcd gcd (the integer arg))))
- gcd))))
-
-(define-more-fun lcm (&rest integers)
+ (do ((result (nth 0 integers)
+ (gcd result (the integer (nth i integers))))
+ (i 1 (1+ i)))
+ ((>= i (length integers))
+ result)
+ (declare (integer result))))))
+
+(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."
- (case (more-count)
+ (case (length integers)
(0 1)
- (1 (abs (the integer (more-arg 0))))
+ (1 (abs (the integer (nth 0 integers))))
(otherwise
- (let ((lcm (more-arg 0)))
- (declare (integer lcm))
- (do-more (arg 1)
- (setf lcm (lcm lcm (the integer arg))))
- lcm))))
+ (do ((result (nth 0 integers)
+ (lcm result (the integer (nth i integers))))
+ (i 1 (1+ i)))
+ ((>= i (length integers))
+ result)
+ (declare (integer result))))))
(defun two-arg-lcm (n m)
(declare (integer n m))
((fixnum bignum)
(bignum-gcd (make-small-bignum u) v))))))
\f
-;;;; from Robert Smith; slightly changed not to cons unnecessarily.
+;;; from Robert Smith; changed not to cons unnecessarily, and tuned for
+;;; faster operation on fixnum inputs by compiling the central recursive
+;;; algorithm twice, once using generic and once fixnum arithmetic, and
+;;; dispatching on function entry into the applicable part. For maximum
+;;; speed, the fixnum part recurs into itself, thereby avoiding further
+;;; type dispatching. This pattern is not supported by NUMBER-DISPATCH
+;;; thus some special-purpose macrology is needed.
(defun isqrt (n)
#!+sb-doc
"Return the greatest integer less than or equal to the square root of N."
(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)))
- (multiple-value-bind (quot rem)
- (floor n zeroth-iteration)
- (let ((first-iteration (ash (+ zeroth-iteration quot) -1)))
- (cond ((oddp quot)
- first-iteration)
- ((> (expt (- first-iteration zeroth-iteration) 2) rem)
- (1- first-iteration))
- (t
- first-iteration))))))
- ((> n 15) 4)
- ((> n 8) 3)
- ((> n 3) 2)
- ((> n 0) 1)
- ((= n 0) 0)))
+ (macrolet
+ ((isqrt-recursion (arg recurse fixnum-p)
+ ;; Expands into code for the recursive step of the ISQRT
+ ;; calculation. ARG is the input variable and RECURSE the name
+ ;; of the function to recur into. If FIXNUM-P is true, some
+ ;; type declarations are added that, together with ARG being
+ ;; declared as a fixnum outside of here, make the resulting code
+ ;; compile into fixnum-specialized code without any calls to
+ ;; generic arithmetic. Else, the code works for bignums, too.
+ ;; The input must be at least 16 to ensure that RECURSE is called
+ ;; with a strictly smaller number and that the result is correct
+ ;; (provided that RECURSE correctly implements ISQRT, itself).
+ `(macrolet ((if-fixnum-p-truly-the (type expr)
+ ,@(if fixnum-p
+ '(`(truly-the ,type ,expr))
+ '((declare (ignore type))
+ expr))))
+ (let* ((fourth-size (ash (1- (integer-length ,arg)) -2))
+ (significant-half (ash ,arg (- (ash fourth-size 1))))
+ (significant-half-isqrt
+ (if-fixnum-p-truly-the
+ (integer 1 #.(isqrt sb!xc:most-positive-fixnum))
+ (,recurse significant-half)))
+ (zeroth-iteration (ash significant-half-isqrt
+ fourth-size)))
+ (multiple-value-bind (quot rem)
+ (floor ,arg zeroth-iteration)
+ (let ((first-iteration (ash (+ zeroth-iteration quot) -1)))
+ (cond ((oddp quot)
+ first-iteration)
+ ((> (if-fixnum-p-truly-the
+ fixnum
+ (expt (- first-iteration zeroth-iteration) 2))
+ rem)
+ (1- first-iteration))
+ (t
+ first-iteration))))))))
+ (typecase n
+ (fixnum (labels ((fixnum-isqrt (n)
+ (declare (type fixnum n))
+ (cond ((> n 24)
+ (isqrt-recursion n fixnum-isqrt t))
+ ((> n 15) 4)
+ ((> n 8) 3)
+ ((> n 3) 2)
+ ((> n 0) 1)
+ ((= n 0) 0))))
+ (fixnum-isqrt n)))
+ (bignum (isqrt-recursion n isqrt nil)))))
\f
;;;; miscellaneous number predicates
projects / sbcl.git / blobdiff