X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fnumbers.lisp;h=e6ae2979c42237d0cc36df3d7613ec4de3f27a25;hb=f569125f053885898e83203324a72e11c9de0f85;hp=8e7e6ed0a9d2a3b461008e275281a5b097848a0d;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 8e7e6ed..e6ae297 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)) @@ -227,7 +231,7 @@ (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) @@ -251,7 +255,7 @@ (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) @@ -267,7 +271,7 @@ (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) @@ -319,9 +323,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 @@ -329,8 +335,8 @@ (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)) @@ -405,7 +411,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,18 +685,18 @@ (+ rem divisor) rem))) -(macrolet ((def-frob (name op doc) +(macrolet ((def (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 + (def ffloor floor "Same as FLOOR, but returns first value as a float.") - (def-frob fceiling ceiling + (def fceiling ceiling "Same as CEILING, but returns first value as a float." ) - (def-frob ftruncate truncate + (def ftruncate truncate "Same as TRUNCATE, but returns first value as a float.") - (def-frob fround round + (def fround round "Same as ROUND, but returns first value as a float.")) ;;;; comparisons @@ -759,6 +765,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 +775,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 +887,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 +919,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 +929,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 +939,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 +949,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 +990,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 +1226,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 +1327,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?"))