X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=34ad585768b18edd4d9e60e711cbc120626a87d6;hb=ec735ab75335c1744b39190314142a7e6f1ecdb3;hp=1e93c38e5483f921fde988d152571cda79b19f60;hpb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 1e93c38..34ad585 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -67,11 +67,11 @@ (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)) @@ -194,9 +194,13 @@ (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)) @@ -207,10 +211,11 @@ ;;;; 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) @@ -319,9 +324,11 @@ `(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 @@ -405,7 +412,7 @@ (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) @@ -679,19 +686,20 @@ (+ 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.") ;;;; comparisons @@ -759,6 +767,7 @@ (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) @@ -768,6 +777,7 @@ (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) @@ -879,12 +889,12 @@ 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) @@ -911,7 +921,8 @@ (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) @@ -920,7 +931,8 @@ (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) @@ -929,7 +941,8 @@ (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) @@ -938,7 +951,8 @@ (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) @@ -978,13 +992,13 @@ (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 @@ -1214,7 +1228,7 @@ (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))))) ;;;; GCD and LCM @@ -1315,10 +1329,10 @@ ;;;; 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?"))