X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=6a2dd702163a9f0813e1422c9f2959dd3dcd9ee3;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=3f02be24e69dc65c015e07684a9e45c011fe3ead;hpb=c45da820b56cd0bd4bd958b66639fa021054f962;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 3f02be2..6a2dd70 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -238,7 +238,7 @@ (defun realpart (number) #!+sb-doc "Extract the real part of a number." - (typecase number + (etypecase number #!+long-float ((complex long-float) (truly-the long-float (realpart number))) @@ -248,13 +248,13 @@ (truly-the single-float (realpart number))) ((complex rational) (sb!kernel:%realpart number)) - (t + (number number))) (defun imagpart (number) #!+sb-doc "Extract the imaginary part of a number." - (typecase number + (etypecase number #!+long-float ((complex long-float) (truly-the long-float (imagpart number))) @@ -266,13 +266,14 @@ (sb!kernel:%imagpart number)) (float (* 0 number)) - (t + (number 0))) (defun conjugate (number) #!+sb-doc "Return the complex conjugate of NUMBER. For non-complex numbers, this is an identity." + (declare (type number number)) (if (complexp number) (complex (realpart number) (- (imagpart number))) number)) @@ -362,9 +363,9 @@ (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float #!+long-float long-float) complex) - (complex (,op x (realpart y)) (,op (imagpart y)))) + (complex (,op x (realpart y)) (,op 0 (imagpart y)))) ((complex (or rational float)) - (complex (,op (realpart x) y) (imagpart x))) + (complex (,op (realpart x) y) (,op (imagpart x) 0))) (((foreach fixnum bignum) ratio) (let* ((dy (denominator y)) @@ -742,7 +743,7 @@ (defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (the number number) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -752,7 +753,7 @@ (defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((head (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -766,7 +767,7 @@ (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -776,7 +777,7 @@ (defun > (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -786,7 +787,7 @@ (defun <= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -796,7 +797,7 @@ (defun >= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -807,7 +808,7 @@ #!+sb-doc "Return the greatest of its arguments; among EQUALP greatest, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -819,7 +820,7 @@ the first." #!+sb-doc "Return the least of its arguments; among EQUALP least, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -827,15 +828,6 @@ the first." (declare (type real number result)) (if (< (car nlist) result) (setq result (car nlist))))) -(defconstant most-positive-exactly-single-float-fixnum - (min #xffffff most-positive-fixnum)) -(defconstant most-negative-exactly-single-float-fixnum - (max #x-ffffff most-negative-fixnum)) -(defconstant most-positive-exactly-double-float-fixnum - (min #x1fffffffffffff most-positive-fixnum)) -(defconstant most-negative-exactly-double-float-fixnum - (max #x-1fffffffffffff most-negative-fixnum)) - (eval-when (:compile-toplevel :execute) ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how @@ -1304,30 +1296,30 @@ the first." ;;;; GCD and LCM -(defun gcd (&rest numbers) +(defun gcd (&rest integers) #!+sb-doc "Return the greatest common divisor of the arguments, which must be integers. Gcd with no arguments is defined to be 0." - (cond ((null numbers) 0) - ((null (cdr numbers)) (abs (the integer (car numbers)))) + (cond ((null integers) 0) + ((null (cdr integers)) (abs (the integer (car integers)))) (t - (do ((gcd (the integer (car numbers)) + (do ((gcd (the integer (car integers)) (gcd gcd (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) + (rest (cdr integers) (cdr rest))) ((null rest) gcd) (declare (integer gcd) (list rest)))))) -(defun lcm (&rest numbers) +(defun lcm (&rest integers) #!+sb-doc "Return the least common multiple of one or more integers. LCM of no arguments is defined to be 1." - (cond ((null numbers) 1) - ((null (cdr numbers)) (abs (the integer (car numbers)))) + (cond ((null integers) 1) + ((null (cdr integers)) (abs (the integer (car integers)))) (t - (do ((lcm (the integer (car numbers)) + (do ((lcm (the integer (car integers)) (lcm lcm (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) + (rest (cdr integers) (cdr rest))) ((null rest) lcm) (declare (integer lcm) (list rest)))))) @@ -1340,6 +1332,10 @@ the first." ;; 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 + ;; + ;; It seems to me that this is written this way to avoid + ;; unnecessary bignumification of intermediate results. + ;; -- TCR, 2008-03-05 (let ((m (abs m)) (n (abs n))) (multiple-value-bind (max min) @@ -1425,30 +1421,18 @@ the first." ;;;; 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-class-funs sb!c::*unsigned-modular-class*) - ;; 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))) - -#. -(collect ((forms)) - (flet ((definition (name lambda-list width) + (flet ((unsigned-definition (name lambda-list width) + (let ((pattern (1- (ash 1 width)))) + `(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))))))) + (signed-definition (name lambda-list width) `(defun ,name ,lambda-list (flet ((prepare-argument (x) (declare (integer x)) @@ -1458,15 +1442,23 @@ the first." (bignum (sb!c::mask-signed-field ,width x))))) (,name ,@(loop for arg in lambda-list collect `(prepare-argument ,arg))))))) - (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*) - ;; 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) - do (forms (definition name lambda-list width))))) - `(progn ,@(forms))) + (flet ((do-mfuns (class) + (loop for infos being each hash-value of (sb!c::modular-class-funs class) + ;; 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 signedp = (sb!c::modular-fun-info-signedp info) + and lambda-list = (sb!c::modular-fun-info-lambda-list info) + if signedp + do (forms (signed-definition name lambda-list width)) + else + do (forms (unsigned-definition name lambda-list width)))))) + (do-mfuns sb!c::*untagged-unsigned-modular-class*) + (do-mfuns sb!c::*untagged-signed-modular-class*) + (do-mfuns sb!c::*tagged-modular-class*))) + `(progn ,@(sort (forms) #'string< :key #'cadr))) ;;; KLUDGE: these out-of-line definitions can't use the modular ;;; arithmetic, as that is only (currently) defined for constant