(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)
+(defun upgraded-complex-part-type (spec &optional environment)
#!+sb-doc
"Return the element type of the most specialized COMPLEX number type that
can hold parts of type SPEC."
+ (declare (ignore environment))
(cond ((unknown-type-p (specifier-type spec))
(error "undefined type: ~S" spec))
((subtypep spec 'single-float)
`(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
"Return the sum of its arguments. With no args, returns 0.")
(define-arith * 1
(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)
(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
(+ 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))))
+
+(!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.")
\f
;;;; comparisons
(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)
(result number))
((null nlist) (return result))
(declare (list nlist))
+ (declare (type real number result))
(if (< (car nlist) result) (setq result (car nlist)))))
(eval-when (:compile-toplevel :execute)
(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)
(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)
(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)
(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)
(fixnum (lognot (truly-the fixnum number)))
(bignum (bignum-logical-not number))))
-(macrolet ((def-frob (name op big-op)
+(macrolet ((def (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))
+ (def two-arg-and logand bignum-logical-and)
+ (def two-arg-ior logior bignum-logical-ior)
+ (def two-arg-xor logxor bignum-logical-xor))
(defun logcount (integer)
#!+sb-doc
(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
\f
;;;; miscellaneous number predicates
-(macrolet ((def-frob (name doc)
+(macrolet ((def (name doc)
`(defun ,name (number) ,doc (,name number))))
- (def-frob zerop "Is this number zero?")
- (def-frob plusp "Is this real number strictly positive?")
- (def-frob minusp "Is this real number strictly negative?")
- (def-frob oddp "Is this integer odd?")
- (def-frob evenp "Is this integer even?"))
+ (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)
+ ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
+ ;; 'BIGNUM-ELEMENT-TYPE)
+ `(defun ,name ,lambda-list
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((unsigned-byte ,width) x)
+ (bignum-element-type (logand x ,pattern))
+ (fixnum (logand x ,pattern))
+ (bignum (logand (%bignum-ref x 0) ,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
+ unless (eq infos :good)
+ 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)))