X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=ff3e6d5f3675f65f7478faf22819ff9d6d83ebeb;hb=1476586427d13b59571fa2c2a0d3836496b4c803;hp=fac1b02aa91c81a36e3b1d741bffab28810de24a;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index fac1b02..ff3e6d5 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -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) @@ -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,37 @@ ;;;; 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?")) + +;;;; 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)))