;;; Return an ETYPECASE form that does the type dispatch, ordering the
;;; cases for efficiency.
+;;; Check for some simple to detect problematic cases where the caller
+;;; used types that are not disjoint and where this may lead to
+;;; unexpected behaviour of the generated form, for example making
+;;; a clause unreachable, and throw an error if such a case is found.
+;;; An example:
+;;; (number-dispatch ((var1 integer) (var2 float))
+;;; ((fixnum single-float) a)
+;;; ((integer float) b))
+;;; Even though the types are not reordered here, the generated form,
+;;; basically
+;;; (etypecase var1
+;;; (fixnum (etypecase var2
+;;; (single-float a)))
+;;; (integer (etypecase var2
+;;; (float b))))
+;;; would fail at runtime if given var1 fixnum and var2 double-float,
+;;; even though the second clause matches this signature. To catch
+;;; this earlier than runtime we throw an error already here.
(defun generate-number-dispatch (vars error-tags cases)
(if vars
(let ((var (first vars))
(cases (sort cases #'type-test-order :key #'car)))
+ (flet ((error-if-sub-or-supertype (type1 type2)
+ (when (or (subtypep type1 type2)
+ (subtypep type2 type1))
+ (error "Types not disjoint: ~S ~S." type1 type2)))
+ (error-if-supertype (type1 type2)
+ (when (subtypep type2 type1)
+ (error "Type ~S ordered before subtype ~S."
+ type1 type2)))
+ (test-type-pairs (fun)
+ ;; Apply FUN to all (ordered) pairs of types from the
+ ;; cases.
+ (mapl (lambda (cases)
+ (when (cdr cases)
+ (let ((type1 (caar cases)))
+ (dolist (case (cdr cases))
+ (funcall fun type1 (car case))))))
+ cases)))
+ ;; For the last variable throw an error if a type is followed
+ ;; by a subtype, for all other variables additionally if a
+ ;; type is followed by a supertype.
+ (test-type-pairs (if (cdr vars)
+ #'error-if-sub-or-supertype
+ #'error-if-supertype)))
`((typecase ,var
,@(mapcar (lambda (case)
`(,(first case)
;;; symbol. In this case, we apply the CAR of the form to the CDR and
;;; treat the result of the call as a list of cases. This process is
;;; not applied recursively.
+;;;
+;;; Be careful when using non-disjoint types in different cases for the
+;;; same variable. Some uses will behave as intended, others not, as the
+;;; variables are dispatched off sequentially and clauses are reordered
+;;; for efficiency. Some, but not all, problematic cases are detected
+;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above
+;;; for an example.
(defmacro number-dispatch (var-specs &body cases)
(let ((res (list nil))
(vars (mapcar #'car var-specs))
(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))
- `(defun ,op (&rest args)
- #!+sb-doc ,doc
- (if (null args) ,init
- (do ((args (cdr args) (cdr args))
- (result (car args) (,op result (car args))))
- ((null args) result)
- ;; to signal TYPE-ERROR when exactly 1 arg of wrong type:
- (declare (type number result)))))))
+ `(defun ,op (&rest numbers)
+ #!+sb-doc
+ ,doc
+ (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
"Subtract the second and all subsequent arguments from the first;
or with one argument, negate the first argument."
(if more-numbers
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((atom nlist) result)
- (declare (list nlist))
- (setq result (- result (car nlist))))
+ (let ((result number))
+ (dotimes (i (length more-numbers) result)
+ (setf result (- result (nth i more-numbers)))))
(- number)))
(defun / (number &rest more-numbers)
"Divide the first argument by each of the following arguments, in turn.
With one argument, return reciprocal."
(if more-numbers
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((atom nlist) result)
- (declare (list nlist))
- (setq result (/ result (car nlist))))
+ (let ((result number))
+ (dotimes (i (length more-numbers) result)
+ (setf result (/ result (nth i more-numbers)))))
(/ number)))
(defun 1+ (number)
(defun = (number &rest more-numbers)
#!+sb-doc
"Return T if all of its arguments are numerically equal, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (the number number)
- (do ((nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (= (car nlist) number)) (return nil))))
+ (declare (number number))
+ (dotimes (i (length more-numbers) t)
+ (unless (= number (nth i more-numbers))
+ (return nil))))
(defun /= (number &rest more-numbers)
#!+sb-doc
"Return T if no two of its arguments are numerically equal, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (do* ((head (the number number) (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (unless (do* ((nl nlist (cdr nl)))
- ((atom nl) t)
- (declare (list nl))
- (if (= head (car nl)) (return nil)))
- (return nil))))
-
-(defun < (number &rest more-numbers)
- #!+sb-doc
- "Return T if its arguments are in strictly increasing order, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (do* ((n (the number number) (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
- #!+sb-doc
- "Return T if its arguments are in strictly decreasing order, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (do* ((n (the number number) (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
- #!+sb-doc
- "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (do* ((n (the number number) (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
- #!+sb-doc
- "Return T if arguments are in strictly non-increasing order, NIL otherwise."
- (declare (truly-dynamic-extent more-numbers))
- (do* ((n (the number number) (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (>= n (car nlist))) (return nil))))
+ (declare (number number))
+ (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))
+ `(defun ,op (number &rest more-numbers)
+ #!+sb-doc ,doc
+ (let ((n number))
+ (declare (number n))
+ (dotimes (i (length more-numbers) t)
+ (let ((arg (nth i more-numbers)))
+ (if (,op n arg)
+ (setf n arg)
+ (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."))
(defun max (number &rest more-numbers)
#!+sb-doc
"Return the greatest of its arguments; among EQUALP greatest, return
the first."
- (declare (truly-dynamic-extent more-numbers))
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((null nlist) (return result))
- (declare (list nlist))
- (declare (type real number result))
- (if (> (car nlist) result) (setq result (car nlist)))))
+ (let ((n number))
+ (declare (number n))
+ (dotimes (i (length more-numbers) n)
+ (let ((arg (nth i more-numbers)))
+ (when (> arg n)
+ (setf n arg))))))
(defun min (number &rest more-numbers)
#!+sb-doc
"Return the least of its arguments; among EQUALP least, return
the first."
- (declare (truly-dynamic-extent more-numbers))
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((null nlist) (return result))
- (declare (list nlist))
- (declare (type real number result))
- (if (< (car nlist) result) (setq result (car nlist)))))
+ (let ((n number))
+ (declare (number n))
+ (dotimes (i (length more-numbers) n)
+ (let ((arg (nth i more-numbers)))
+ (when (< arg n)
+ (setf n arg))))))
(eval-when (:compile-toplevel :execute)
\f
;;;; logicals
-(defun logior (&rest integers)
- #!+sb-doc
- "Return the bit-wise or of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logior result (pop integers))))
- ((null integers) result)
- (declare (integer result)))
- 0))
-
-(defun logxor (&rest integers)
- #!+sb-doc
- "Return the bit-wise exclusive or of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logxor result (pop integers))))
- ((null integers) result)
- (declare (integer result)))
- 0))
-
-(defun logand (&rest integers)
- #!+sb-doc
- "Return the bit-wise and of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logand result (pop integers))))
- ((null integers) result)
- (declare (integer result)))
- -1))
-
-(defun logeqv (&rest integers)
- #!+sb-doc
- "Return the bit-wise equivalence of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logeqv result (pop integers))))
- ((null integers) result)
- (declare (integer result)))
- -1))
+(macrolet ((def (op init doc)
+ #!-sb-doc (declare (ignore doc))
+ `(defun ,op (&rest integers)
+ #!+sb-doc ,doc
+ (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.")
+ (def logand -1 "Return the bit-wise and of its arguments. Args must be integers.")
+ (def logeqv -1 "Return the bit-wise equivalence of its arguments. Args must be integers."))
(defun lognot (number)
#!+sb-doc
#!+sb-doc
"Predicate returns T if bit index of integer is a 1."
(number-dispatch ((index integer) (integer integer))
- ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits))
- (minusp integer)
- (not (zerop (logand integer (ash 1 index))))))
+ ((fixnum fixnum) (if (< index sb!vm:n-positive-fixnum-bits)
+ (not (zerop (logand integer (ash 1 index))))
+ (minusp integer)))
((fixnum bignum) (bignum-logbitp index integer))
((bignum (foreach fixnum bignum)) (minusp integer))))
(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)))))
(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 integers) 0)
- ((null (cdr integers)) (abs (the integer (car integers))))
- (t
- (do ((gcd (the integer (car integers))
- (gcd gcd (the integer (car rest))))
- (rest (cdr integers) (cdr rest)))
- ((null rest) gcd)
- (declare (integer gcd)
- (list rest))))))
+ integers. GCD with no arguments is defined to be 0."
+ (case (length integers)
+ (0 0)
+ (1 (abs (the integer (nth 0 integers))))
+ (otherwise
+ (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."
- (cond ((null integers) 1)
- ((null (cdr integers)) (abs (the integer (car integers))))
- (t
- (do ((lcm (the integer (car integers))
- (lcm lcm (the integer (car rest))))
- (rest (cdr integers) (cdr rest)))
- ((null rest) lcm)
- (declare (integer lcm) (list rest))))))
+ (case (length integers)
+ (0 1)
+ (1 (abs (the integer (nth 0 integers))))
+ (otherwise
+ (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
+;;; 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 root of the nearest integer less than n which is a perfect
- square."
+ "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))
- (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)))
+ (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