(let ((var (first vars))
(cases (sort cases #'type-test-order :key #'car)))
`((typecase ,var
- ,@(mapcar #'(lambda (case)
- `(,(first case)
- ,@(generate-number-dispatch (rest vars)
- (rest error-tags)
- (cdr case))))
+ ,@(mapcar (lambda (case)
+ `(,(first case)
+ ,@(generate-number-dispatch (rest vars)
+ (rest error-tags)
+ (cdr case))))
cases)
(t (go ,(first error-tags))))))
cases))
(if (minusp den)
(values (- num) (- den))
(values num den))
- (if (eql den 1)
- num
- (%make-ratio num den))))
+ (cond
+ ((eql den 0)
+ (error 'division-by-zero
+ :operands (list num den)
+ :operation 'build-ratio))
+ ((eql den 1) num)
+ (t (%make-ratio num den)))))
;;; Truncate X and Y, but bum the case where Y is 1.
#!-sb-fluid (declaim (inline maybe-truncate))
\f
;;;; COMPLEXes
-(defun upgraded-complex-part-type (spec)
- #!+sb-doc
- "Returns the element type of the most specialized COMPLEX number type that
- can hold parts of type SPEC."
- (cond ((unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec))
- ((subtypep spec 'single-float)
- 'single-float)
- ((subtypep spec 'double-float)
- 'double-float)
- #!+long-float
- ((subtypep spec 'long-float)
- 'long-float)
- ((subtypep spec 'rational)
- 'rational)
- (t
- 'real)))
-
(defun complex (realpart &optional (imagpart 0))
#!+sb-doc
- "Builds a complex number from the specified components."
+ "Return a complex number with the specified real and imaginary components."
(flet ((%%make-complex (realpart imagpart)
(cond #!+long-float
((and (typep realpart 'long-float)
(defun realpart (number)
#!+sb-doc
- "Extracts the real part of a number."
+ "Extract the real part of a number."
(typecase number
#!+long-float
((complex long-float)
(defun imagpart (number)
#!+sb-doc
- "Extracts the imaginary part of a number."
+ "Extract the imaginary part of a number."
(typecase number
#!+long-float
((complex long-float)
((complex rational)
(sb!kernel:%imagpart number))
(float
- (float 0 number))
+ (* 0 number))
(t
0)))
(defun conjugate (number)
#!+sb-doc
- "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
+ "Return the complex conjugate of NUMBER. For non-complex numbers, this is
an identity."
(if (complexp number)
(complex (realpart number) (- (imagpart number)))
`(defun ,op (&rest args)
#!+sb-doc ,doc
(if (null args) ,init
- (do ((args (cdr args) (cdr args))
- (res (car args) (,op res (car args))))
- ((null args) res))))))
+ (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)))))))
(define-arith + 0
- "Returns the sum of its arguments. With no args, returns 0.")
+ "Return the sum of its arguments. With no args, returns 0.")
(define-arith * 1
- "Returns the product of its arguments. With no args, returns 1."))
+ "Return the product of its arguments. With no args, returns 1."))
(defun - (number &rest more-numbers)
#!+sb-doc
- "Subtracts the second and all subsequent arguments from the first.
- With one arg, negates it."
+ "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))
(defun 1+ (number)
#!+sb-doc
- "Returns NUMBER + 1."
+ "Return NUMBER + 1."
(1+ number))
(defun 1- (number)
#!+sb-doc
- "Returns NUMBER - 1."
+ "Return NUMBER - 1."
(1- number))
(eval-when (:compile-toplevel)
(cond ((eql t1 0) 0)
((eql g2 1)
(%make-ratio t1 (* t2 dy)))
- (T (let* ((nn (truncate t1 g2))
+ (t (let* ((nn (truncate t1 g2))
(t3 (truncate dy g2))
(nd (if (eql t2 1) t3 (* t2 t3))))
(if (eql nd 1) nn (%make-ratio nn nd))))))))))))
-); Eval-When (Compile)
+) ; EVAL-WHEN
(two-arg-+/- two-arg-+ + add-bignums)
(two-arg-+/- two-arg-- - subtract-bignum)
(defun truncate (number &optional (divisor 1))
#!+sb-doc
- "Returns number (or number/divisor) as an integer, rounded toward 0.
+ "Return number (or number/divisor) as an integer, rounded toward 0.
The second returned value is the remainder."
(macrolet ((truncate-float (rtype)
`(let* ((float-div (coerce divisor ',rtype))
(numerator divisor))))
(values q (- number (* q divisor)))))
((fixnum bignum)
- (values 0 number))
+ (bignum-truncate (make-small-bignum number) divisor))
((ratio (or float rational))
(let ((q (truncate (numerator number)
(* (denominator number) divisor))))
(defun floor (number &optional (divisor 1))
#!+sb-doc
- "Returns the greatest integer not greater than number, or number/divisor.
+ "Return the greatest integer not greater than number, or number/divisor.
The second returned value is (mod number divisor)."
;; If the numbers do not divide exactly and the result of
;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
(defun ceiling (number &optional (divisor 1))
#!+sb-doc
- "Returns the smallest integer not less than number, or number/divisor.
+ "Return the smallest integer not less than number, or number/divisor.
The second returned value is the remainder."
;; If the numbers do not divide exactly and the result of
;; (/ NUMBER DIVISOR) would be positive then increment the quotient
(if (eql divisor 1)
(round number)
(multiple-value-bind (tru rem) (truncate number divisor)
- (let ((thresh (/ (abs divisor) 2)))
- (cond ((or (> rem thresh)
- (and (= rem thresh) (oddp tru)))
- (if (minusp divisor)
- (values (- tru 1) (+ rem divisor))
- (values (+ tru 1) (- rem divisor))))
- ((let ((-thresh (- thresh)))
- (or (< rem -thresh)
- (and (= rem -thresh) (oddp tru))))
- (if (minusp divisor)
- (values (+ tru 1) (- rem divisor))
- (values (- tru 1) (+ rem divisor))))
- (t (values tru rem)))))))
+ (if (zerop rem)
+ (values tru rem)
+ (let ((thresh (/ (abs divisor) 2)))
+ (cond ((or (> rem thresh)
+ (and (= rem thresh) (oddp tru)))
+ (if (minusp divisor)
+ (values (- tru 1) (+ rem divisor))
+ (values (+ tru 1) (- rem divisor))))
+ ((let ((-thresh (- thresh)))
+ (or (< rem -thresh)
+ (and (= rem -thresh) (oddp tru))))
+ (if (minusp divisor)
+ (values (+ tru 1) (- rem divisor))
+ (values (- tru 1) (+ rem divisor))))
+ (t (values tru rem))))))))
(defun rem (number divisor)
#!+sb-doc
- "Returns second result of TRUNCATE."
+ "Return second result of TRUNCATE."
(multiple-value-bind (tru rem) (truncate number divisor)
(declare (ignore tru))
rem))
(defun mod (number divisor)
#!+sb-doc
- "Returns second result of FLOOR."
+ "Return second result of FLOOR."
(let ((rem (rem number divisor)))
(if (and (not (zerop rem))
(if (minusp divisor)
(+ rem divisor)
rem)))
-(macrolet ((def-frob (name op doc)
- `(defun ,name (number &optional (divisor 1))
- ,doc
- (multiple-value-bind (res rem) (,op number divisor)
- (values (float res (if (floatp rem) rem 1.0)) rem)))))
- (def-frob ffloor floor
- "Same as FLOOR, but returns first value as a float.")
- (def-frob fceiling ceiling
- "Same as CEILING, but returns first value as a float." )
- (def-frob ftruncate truncate
- "Same as TRUNCATE, but returns first value as a float.")
- (def-frob fround round
- "Same as ROUND, but returns first value as a float."))
+(defmacro !define-float-rounding-function (name op doc)
+ `(defun ,name (number &optional (divisor 1))
+ ,doc
+ (multiple-value-bind (res rem) (,op number divisor)
+ (values (float res (if (floatp rem) rem 1.0)) rem))))
+
+(defun ftruncate (number &optional (divisor 1))
+ #!+sb-doc
+ "Same as TRUNCATE, but returns first value as a float."
+ (macrolet ((ftruncate-float (rtype)
+ `(let* ((float-div (coerce divisor ',rtype))
+ (res (%unary-ftruncate (/ number float-div))))
+ (values res
+ (- number
+ (* (coerce res ',rtype) float-div))))))
+ (number-dispatch ((number real) (divisor real))
+ (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+ (multiple-value-bind (q r)
+ (truncate number divisor)
+ (values (float q) r)))
+ (((foreach single-float double-float #!+long-float long-float)
+ (or rational single-float))
+ (if (eql divisor 1)
+ (let ((res (%unary-ftruncate number)))
+ (values res (- number (coerce res '(dispatch-type number)))))
+ (ftruncate-float (dispatch-type number))))
+ #!+long-float
+ ((long-float (or single-float double-float long-float))
+ (ftruncate-float long-float))
+ #!+long-float
+ (((foreach double-float single-float) long-float)
+ (ftruncate-float long-float))
+ ((double-float (or single-float double-float))
+ (ftruncate-float double-float))
+ ((single-float double-float)
+ (ftruncate-float double-float))
+ (((foreach fixnum bignum ratio)
+ (foreach single-float double-float #!+long-float long-float))
+ (ftruncate-float (dispatch-type divisor))))))
+
+(defun ffloor (number &optional (divisor 1))
+ "Same as FLOOR, but returns first value as a float."
+ (multiple-value-bind (tru rem) (ftruncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem divisor))
+ (values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+ "Same as CEILING, but returns first value as a float."
+ (multiple-value-bind (tru rem) (ftruncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (minusp number)
+ (plusp number)))
+ (values (+ tru 1) (- rem divisor))
+ (values tru rem))))
+
+;;; FIXME: this probably needs treatment similar to the use of
+;;; %UNARY-FTRUNCATE for FTRUNCATE.
+(defun fround (number &optional (divisor 1))
+ "Same as ROUND, but returns first value as a float."
+ (multiple-value-bind (res rem)
+ (round number divisor)
+ (values (float res (if (floatp rem) rem 1.0)) rem)))
\f
;;;; comparisons
(defun = (number &rest more-numbers)
#!+sb-doc
- "Returns T if all of its arguments are numerically equal, NIL otherwise."
+ "Return T if all of its arguments are numerically equal, NIL otherwise."
+ (the number number)
(do ((nlist more-numbers (cdr nlist)))
- ((atom nlist) T)
+ ((atom nlist) t)
(declare (list nlist))
(if (not (= (car nlist) number)) (return nil))))
(defun /= (number &rest more-numbers)
#!+sb-doc
- "Returns T if no two of its arguments are numerically equal, NIL otherwise."
- (do* ((head number (car nlist))
+ "Return T if no two of its arguments are numerically equal, NIL otherwise."
+ (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)
+ ((atom nl) t)
(declare (list nl))
(if (= head (car nl)) (return nil)))
(return nil))))
(defun < (number &rest more-numbers)
#!+sb-doc
- "Returns T if its arguments are in strictly increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ "Return T if its arguments are in strictly increasing order, NIL otherwise."
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun > (number &rest more-numbers)
#!+sb-doc
- "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ "Return T if its arguments are in strictly decreasing order, NIL otherwise."
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun <= (number &rest more-numbers)
#!+sb-doc
- "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun >= (number &rest more-numbers)
#!+sb-doc
- "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ "Return T if arguments are in strictly non-increasing order, NIL otherwise."
+ (do* ((n (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun max (number &rest more-numbers)
#!+sb-doc
- "Returns the greatest of its arguments."
+ "Return the greatest of its arguments; among EQUALP greatest, return
+the first."
(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)))))
(defun min (number &rest more-numbers)
#!+sb-doc
- "Returns the least of its arguments."
+ "Return the least of its arguments; among EQUALP least, return
+the first."
(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)))))
+(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
#!+long-float
((long-float (foreach single-float double-float))
(,op x (coerce y 'long-float)))
+ ((fixnum (foreach single-float double-float))
+ (if (float-infinity-p y)
+ ,infinite-y-finite-x
+ ;; If the fixnum has an exact float representation, do a
+ ;; float comparison. Otherwise do the slow float -> ratio
+ ;; conversion.
+ (multiple-value-bind (lo hi)
+ (case '(dispatch-type y)
+ ('single-float
+ (values most-negative-exactly-single-float-fixnum
+ most-positive-exactly-single-float-fixnum))
+ ('double-float
+ (values most-negative-exactly-double-float-fixnum
+ most-positive-exactly-double-float-fixnum)))
+ (if (<= lo y hi)
+ (,op (coerce x '(dispatch-type y)) y)
+ (,op x (rational y))))))
+ (((foreach single-float double-float) fixnum)
+ (if (eql y 0)
+ (,op x (coerce 0 '(dispatch-type x)))
+ (if (float-infinity-p x)
+ ,infinite-x-finite-y
+ ;; Likewise
+ (multiple-value-bind (lo hi)
+ (case '(dispatch-type x)
+ ('single-float
+ (values most-negative-exactly-single-float-fixnum
+ most-positive-exactly-single-float-fixnum))
+ ('double-float
+ (values most-negative-exactly-double-float-fixnum
+ most-positive-exactly-double-float-fixnum)))
+ (if (<= lo y hi)
+ (,op x (coerce y '(dispatch-type x)))
+ (,op (rational x) y))))))
(((foreach single-float double-float) double-float)
(,op (coerce x 'double-float) y))
((double-float single-float)
nil
(macrolet ((foo (&rest stuff)
`(typecase obj2
- ,@(mapcar #'(lambda (foo)
- (let ((type (car foo))
- (fn (cadr foo)))
- `(,type
- (and (typep obj1 ',type)
- (,fn obj1 obj2)))))
+ ,@(mapcar (lambda (foo)
+ (let ((type (car foo))
+ (fn (cadr foo)))
+ `(,type
+ (and (typep obj1 ',type)
+ (,fn obj1 obj2)))))
stuff))))
(foo
(single-float eql)
(defun logior (&rest integers)
#!+sb-doc
- "Returns the bit-wise or of its arguments. Args must be integers."
+ "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))
+ ((null integers) result)
+ (declare (integer result)))
0))
(defun logxor (&rest integers)
#!+sb-doc
- "Returns the bit-wise exclusive or of its arguments. Args must be integers."
+ "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))
+ ((null integers) result)
+ (declare (integer result)))
0))
(defun logand (&rest integers)
#!+sb-doc
- "Returns the bit-wise and of its arguments. Args must be integers."
+ "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))
+ ((null integers) result)
+ (declare (integer result)))
-1))
(defun logeqv (&rest integers)
#!+sb-doc
- "Returns the bit-wise equivalence of its arguments. Args must be integers."
+ "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))
+ ((null integers) result)
+ (declare (integer result)))
-1))
-(defun lognand (integer1 integer2)
- #!+sb-doc
- "Returns the complement of the logical AND of integer1 and integer2."
- (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
- #!+sb-doc
- "Returns the complement of the logical OR of integer1 and integer2."
- (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
- #!+sb-doc
- "Returns the logical AND of (LOGNOT integer1) and integer2."
- (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
- #!+sb-doc
- "Returns the logical AND of integer1 and (LOGNOT integer2)."
- (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
- #!+sb-doc
- "Returns the logical OR of (LOGNOT integer1) and integer2."
- (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
- #!+sb-doc
- "Returns the logical OR of integer1 and (LOGNOT integer2)."
- (logorc2 integer1 integer2))
-
(defun lognot (number)
#!+sb-doc
- "Returns the bit-wise logical not of integer."
+ "Return the bit-wise logical not of integer."
(etypecase number
(fixnum (lognot (truly-the fixnum number)))
(bignum (bignum-logical-not number))))
-(macrolet ((def-frob (name op big-op)
- `(defun ,name (x y)
- (number-dispatch ((x integer) (y integer))
- (bignum-cross-fixnum ,op ,big-op)))))
- (def-frob two-arg-and logand bignum-logical-and)
- (def-frob two-arg-ior logior bignum-logical-ior)
- (def-frob two-arg-xor logxor bignum-logical-xor))
+(macrolet ((def (name op big-op &optional doc)
+ `(defun ,name (integer1 integer2)
+ ,@(when doc
+ (list doc))
+ (let ((x integer1)
+ (y integer2))
+ (number-dispatch ((x integer) (y integer))
+ (bignum-cross-fixnum ,op ,big-op))))))
+ (def two-arg-and logand bignum-logical-and)
+ (def two-arg-ior logior bignum-logical-ior)
+ (def two-arg-xor logxor bignum-logical-xor)
+ ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
+ ;; call the generic LOGNOT...
+ (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
+ (def lognand lognand
+ (lambda (x y) (lognot (bignum-logical-and x y)))
+ #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+ (def lognor lognor
+ (lambda (x y) (lognot (bignum-logical-ior x y)))
+ #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+ ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
+ (def logandc1 logandc1
+ (lambda (x y) (bignum-logical-and (bignum-logical-not x) y))
+ #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
+ (def logandc2 logandc2
+ (lambda (x y) (bignum-logical-and x (bignum-logical-not y)))
+ #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
+ (def logorc1 logorc1
+ (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y))
+ #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
+ (def logorc2 logorc2
+ (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
+ #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
(defun logcount (integer)
#!+sb-doc
if INTEGER is negative."
(etypecase integer
(fixnum
- (logcount (truly-the (integer 0 #.(max most-positive-fixnum
- (lognot most-negative-fixnum)))
+ (logcount (truly-the (integer 0
+ #.(max sb!xc:most-positive-fixnum
+ (lognot sb!xc:most-negative-fixnum)))
(if (minusp (truly-the fixnum integer))
(lognot (truly-the fixnum integer))
integer))))
(defun logbitp (index integer)
#!+sb-doc
"Predicate returns T if bit index of integer is a 1."
- (logbitp index integer))
+ (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 bignum) (bignum-logbitp index integer))
+ ((bignum (foreach fixnum bignum)) (minusp integer))))
(defun ash (integer count)
#!+sb-doc
(defun integer-length (integer)
#!+sb-doc
- "Returns the number of significant bits in the absolute value of integer."
+ "Return the number of non-sign bits in the twos-complement representation
+ of INTEGER."
(etypecase integer
(fixnum
(integer-length (truly-the fixnum integer)))
(defun byte (size position)
#!+sb-doc
- "Returns a byte specifier which may be used by other byte functions."
+ "Return a byte specifier which may be used by other byte functions
+ (e.g. LDB)."
(byte size position))
(defun byte-size (bytespec)
#!+sb-doc
- "Returns the size part of the byte specifier bytespec."
+ "Return the size part of the byte specifier bytespec."
(byte-size bytespec))
(defun byte-position (bytespec)
#!+sb-doc
- "Returns the position part of the byte specifier bytespec."
+ "Return the position part of the byte specifier bytespec."
(byte-position bytespec))
(defun ldb (bytespec integer)
(defun ldb-test (bytespec integer)
#!+sb-doc
- "Returns T if any of the specified bits in integer are 1's."
+ "Return T if any of the specified bits in integer are 1's."
(ldb-test bytespec integer))
(defun mask-field (bytespec integer)
(defun dpb (newbyte bytespec integer)
#!+sb-doc
- "Returns new integer with newbyte in specified position, newbyte is right justified."
+ "Return new integer with newbyte in specified position, newbyte is right justified."
(dpb newbyte bytespec integer))
(defun deposit-field (newbyte bytespec integer)
#!+sb-doc
- "Returns new integer with newbyte in specified position, newbyte is not right justified."
+ "Return new integer with newbyte in specified position, newbyte is not right justified."
(deposit-field newbyte bytespec integer))
(defun %ldb (size posn integer)
(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand newbyte mask)
(logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+ #!+sb-doc
+ "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+ (cond ((zerop size)
+ 0)
+ ((logbitp (1- size) integer)
+ (dpb integer (byte size 0) -1))
+ (t
+ (ldb (byte size 0) integer))))
+
\f
;;;; BOOLE
(defun boole (op integer1 integer2)
#!+sb-doc
"Bit-wise boolean function on two integers. Function chosen by OP:
- 0 BOOLE-CLR
- 1 BOOLE-SET
- 2 BOOLE-1
- 3 BOOLE-2
- 4 BOOLE-C1
- 5 BOOLE-C2
- 6 BOOLE-AND
- 7 BOOLE-IOR
- 8 BOOLE-XOR
- 9 BOOLE-EQV
- 10 BOOLE-NAND
- 11 BOOLE-NOR
- 12 BOOLE-ANDC1
- 13 BOOLE-ANDC2
- 14 BOOLE-ORC1
- 15 BOOLE-ORC2"
+ 0 BOOLE-CLR
+ 1 BOOLE-SET
+ 2 BOOLE-1
+ 3 BOOLE-2
+ 4 BOOLE-C1
+ 5 BOOLE-C2
+ 6 BOOLE-AND
+ 7 BOOLE-IOR
+ 8 BOOLE-XOR
+ 9 BOOLE-EQV
+ 10 BOOLE-NAND
+ 11 BOOLE-NOR
+ 12 BOOLE-ANDC1
+ 13 BOOLE-ANDC2
+ 14 BOOLE-ORC1
+ 15 BOOLE-ORC2"
(case op
(0 (boole 0 integer1 integer2))
(1 (boole 1 integer1 integer2))
(13 (boole 13 integer1 integer2))
(14 (boole 14 integer1 integer2))
(15 (boole 15 integer1 integer2))
- (t (error "~S is not of type (mod 16)." op))))
+ (t (error 'type-error :datum op :expected-type '(mod 16)))))
\f
;;;; GCD and LCM
(defun gcd (&rest numbers)
#!+sb-doc
- "Returns the greatest common divisor of the arguments, which must be
+ "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))))
(defun lcm (&rest numbers)
#!+sb-doc
- "Returns the least common multiple of one or more integers. LCM of no
+ "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))))
(defun two-arg-lcm (n m)
(declare (integer n m))
- (* (truncate (max n m) (gcd n m)) (min n m)))
+ (if (or (zerop n) (zerop m))
+ 0
+ ;; KLUDGE: I'm going to assume that it was written this way
+ ;; originally for a reason. However, this is a somewhat
+ ;; 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
+ (let ((m (abs m))
+ (n (abs n)))
+ (multiple-value-bind (max min)
+ (if (> m n)
+ (values m n)
+ (values n m))
+ (* (truncate max (gcd n m)) min)))))
;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
;;; of 0 before the dispatch so that the bignum code doesn't have to worry
;;; about "small bignum" zeros.
(defun two-arg-gcd (u v)
- (cond ((eql u 0) v)
- ((eql v 0) u)
+ (cond ((eql u 0) (abs v))
+ ((eql v 0) (abs u))
(t
(number-dispatch ((u integer) (v integer))
((fixnum fixnum)
;;; From discussion on comp.lang.lisp and Akira Kurihara.
(defun isqrt (n)
#!+sb-doc
- "Returns the root of the nearest integer less than n which is a perfect
+ "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.
\f
;;;; miscellaneous number predicates
-(macrolet ((def-frob (name doc)
+(macrolet ((def (name doc)
`(defun ,name (number) ,doc (,name number))))
- (def-frob zerop "Returns T if number = 0, NIL otherwise.")
- (def-frob plusp "Returns T if number > 0, NIL otherwise.")
- (def-frob minusp "Returns T if number < 0, NIL otherwise.")
- (def-frob oddp "Returns T if number is odd, NIL otherwise.")
- (def-frob evenp "Returns T if number is even, NIL otherwise."))
+ (def zerop "Is this number zero?")
+ (def plusp "Is this real number strictly positive?")
+ (def minusp "Is this real number strictly negative?")
+ (def oddp "Is this integer odd?")
+ (def evenp "Is this integer even?"))
+\f
+;;;; 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)
+ `(defun ,name ,lambda-list
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((signed-byte ,width) x)
+ (fixnum (sb!c::mask-signed-field ,width 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)))
+
+;;; KLUDGE: these out-of-line definitions can't use the modular
+;;; arithmetic, as that is only (currently) defined for constant
+;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
+;;; discussion of this hack. -- CSR, 2003-10-09
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
+(defun sb!vm::ash-left-mod32 (integer amount)
+ (etypecase integer
+ ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
+ (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
+ (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
+(defun sb!vm::ash-left-mod64 (integer amount)
+ (etypecase integer
+ ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
+ (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
+ (bignum (ldb (byte 64 0)
+ (ash (logand integer #xffffffffffffffff) amount)))))
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+ (etypecase integer
+ ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+ (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
+
+#!+x86-64
+(defun sb!vm::ash-left-smod61 (integer amount)
+ (etypecase integer
+ ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
+ (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))
projects / sbcl.git / blobdiff