\f
;;;; COMPLEXes
-(defun upgraded-complex-part-type (spec)
- #!+sb-doc
- "Return 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
"Return a complex number with the specified real and imaginary components."
((complex rational)
(sb!kernel:%imagpart number))
(float
- (float 0 number))
+ (* 0 number))
(t
0)))
(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))))
(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
(multiple-value-bind (res rem) (,op number divisor)
(values (float res (if (floatp rem) rem 1.0)) rem))))
-(!define-float-rounding-function ffloor floor
- "Same as FLOOR, but returns first value as a float.")
-(!define-float-rounding-function fceiling ceiling
- "Same as CEILING, but returns first value as a float." )
-(!define-float-rounding-function ftruncate truncate
- "Same as TRUNCATE, but returns first value as a float.")
-(!define-float-rounding-function fround round
- "Same as ROUND, but returns first value as a float.")
+(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
"Return T if all of its arguments are numerically equal, NIL otherwise."
+ (the number number)
(do ((nlist more-numbers (cdr nlist)))
((atom nlist) T)
(declare (list nlist))
(defun /= (number &rest more-numbers)
#!+sb-doc
"Return T if no two of its arguments are numerically equal, NIL otherwise."
- (do* ((head number (car nlist))
+ (do* ((head (the number number) (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(defun < (number &rest more-numbers)
#!+sb-doc
"Return T if its arguments are in strictly increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (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
"Return T if its arguments are in strictly decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (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
"Return T if arguments are in strictly non-decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (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
"Return T if arguments are in strictly non-increasing order, NIL otherwise."
- (do* ((n number (car nlist))
+ (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
- "Return 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))
(defun min (number &rest more-numbers)
#!+sb-doc
- "Return 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 (integer result)))
-1))
-(defun lognand (integer1 integer2)
- #!+sb-doc
- "Return the complement of the logical AND of integer1 and integer2."
- (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
- #!+sb-doc
- "Return the complement of the logical OR of integer1 and integer2."
- (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
- #!+sb-doc
- "Return the logical AND of (LOGNOT integer1) and integer2."
- (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
- #!+sb-doc
- "Return the logical AND of integer1 and (LOGNOT integer2)."
- (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
- #!+sb-doc
- "Return the logical OR of (LOGNOT integer1) and integer2."
- (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
- #!+sb-doc
- "Return the logical OR of integer1 and (LOGNOT integer2)."
- (logorc2 integer1 integer2))
-
(defun lognot (number)
#!+sb-doc
"Return the bit-wise logical not of integer."
(fixnum (lognot (truly-the fixnum number)))
(bignum (bignum-logical-not number))))
-(macrolet ((def (name op big-op)
- `(defun ,name (x y)
- (number-dispatch ((x integer) (y integer))
- (bignum-cross-fixnum ,op ,big-op)))))
+(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))
+ (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 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))
(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)
(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-funs*
+ ;; 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)))
+
+;;; 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
+#!-alpha
+(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)))))
+#!+alpha
+(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)))))