X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=7bb61f999194ccfbaa2ed0a31e8bf34cd23c750f;hb=4255b37e50876702d2563f3418a44a3f5bf8a2e8;hp=19e6be9e874281e8c5c0963c4cd16805ded55b0c;hpb=91e1d65670542ceb7c177423f25b53d250c9d9cb;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 19e6be9..7bb61f9 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)) @@ -589,19 +590,26 @@ (foreach single-float double-float #!+long-float long-float)) (truncate-float (dispatch-type divisor)))))) +;; Only inline when no VOP exists +#!-multiply-high-vops (declaim (inline %multiply-high)) +(defun %multiply-high (x y) + (declare (type word x y)) + #!-multiply-high-vops + (values (sb!bignum:%multiply x y)) + #!+multiply-high-vops + (%multiply-high x y)) + ;;; Declare these guys inline to let them get optimized a little. ;;; ROUND and FROUND are not declared inline since they seem too ;;; obscure and too big to inline-expand by default. Also, this gives -;;; the compiler a chance to pick off the unary float case. Similarly, -;;; CEILING and FLOOR are only maybe-inline for now, so that the -;;; power-of-2 CEILING and FLOOR transforms get a chance. -#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate)) -(declaim (maybe-inline ceiling floor)) - -(defun floor (number &optional (divisor 1)) - #!+sb-doc - "Return the greatest integer not greater than number, or number/divisor. - The second returned value is (mod number divisor)." +;;; the compiler a chance to pick off the unary float case. +;;; +;;; CEILING and FLOOR are implemented in terms of %CEILING and %FLOOR +;;; if no better transform can be found: they aren't inline directly, +;;; since we want to try a transform specific to them before letting +;;; the transform for TRUNCATE pick up the slack. +#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate %floor %ceiling)) +(defun %floor (number divisor) ;; If the numbers do not divide exactly and the result of ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient ;; and augment the remainder by the divisor. @@ -613,10 +621,13 @@ (values (1- tru) (+ rem divisor)) (values tru rem)))) -(defun ceiling (number &optional (divisor 1)) +(defun floor (number &optional (divisor 1)) #!+sb-doc - "Return the smallest integer not less than number, or number/divisor. - The second returned value is the remainder." + "Return the greatest integer not greater than number, or number/divisor. + The second returned value is (mod number divisor)." + (%floor number divisor)) + +(defun %ceiling (number divisor) ;; If the numbers do not divide exactly and the result of ;; (/ NUMBER DIVISOR) would be positive then increment the quotient ;; and decrement the remainder by the divisor. @@ -628,6 +639,12 @@ (values (+ tru 1) (- rem divisor)) (values tru rem)))) +(defun ceiling (number &optional (divisor 1)) + #!+sb-doc + "Return the smallest integer not less than number, or number/divisor. + The second returned value is the remainder." + (%ceiling number divisor)) + (defun round (number &optional (divisor 1)) #!+sb-doc "Rounds number (or number/divisor) to nearest integer. @@ -742,7 +759,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 +769,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 +783,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 +793,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 +803,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 +813,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 +824,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 +836,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 +844,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 @@ -863,10 +871,10 @@ the first." ;; conversion. (multiple-value-bind (lo hi) (case '(dispatch-type y) - ('single-float + (single-float (values most-negative-exactly-single-float-fixnum most-positive-exactly-single-float-fixnum)) - ('double-float + (double-float (values most-negative-exactly-double-float-fixnum most-positive-exactly-double-float-fixnum))) (if (<= lo y hi) @@ -880,10 +888,10 @@ the first." ;; Likewise (multiple-value-bind (lo hi) (case '(dispatch-type x) - ('single-float + (single-float (values most-negative-exactly-single-float-fixnum most-positive-exactly-single-float-fixnum)) - ('double-float + (double-float (values most-negative-exactly-double-float-fixnum most-positive-exactly-double-float-fixnum))) (if (<= lo y hi) @@ -1077,9 +1085,9 @@ the first." #!+sb-doc "Predicate returns T if bit index of integer is a 1." (number-dispatch ((index integer) (integer integer)) - ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits)) - (minusp integer) - (not (zerop (logand integer (ash 1 index)))))) + ((fixnum fixnum) (if (< index sb!vm:n-positive-fixnum-bits) + (not (zerop (logand integer (ash 1 index)))) + (minusp integer))) ((fixnum bignum) (bignum-logbitp index integer)) ((bignum (foreach fixnum bignum)) (minusp integer)))) @@ -1392,29 +1400,31 @@ the first." ((fixnum bignum) (bignum-gcd (make-small-bignum u) v)))))) -;;; From discussion on comp.lang.lisp and Akira Kurihara. +;;;; from Robert Smith (defun isqrt (n) #!+sb-doc "Return the root of the nearest integer less than n which is a perfect square." - (declare (type unsigned-byte n) (values unsigned-byte)) - ;; Theoretically (> n 7), i.e., n-len-quarter > 0. - (if (and (fixnump n) (<= n 24)) - (cond ((> n 15) 4) - ((> n 8) 3) - ((> n 3) 2) - ((> n 0) 1) - (t 0)) - (let* ((n-len-quarter (ash (integer-length n) -2)) - (n-half (ash n (- (ash n-len-quarter 1)))) - (n-half-isqrt (isqrt n-half)) - (init-value (ash (1+ n-half-isqrt) n-len-quarter))) - (loop - (let ((iterated-value - (ash (+ init-value (truncate n init-value)) -1))) - (unless (< iterated-value init-value) - (return init-value)) - (setq init-value iterated-value)))))) + (declare (type unsigned-byte n)) + (cond + ((> n 24) + (let* ((n-fourth-size (ash (1- (integer-length n)) -2)) + (n-significant-half (ash n (- (ash n-fourth-size 1)))) + (n-significant-half-isqrt (isqrt n-significant-half)) + (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size)) + (qr (multiple-value-list (floor n zeroth-iteration))) + (first-iteration (ash (+ zeroth-iteration (first qr)) -1))) + (cond ((oddp (first qr)) + first-iteration) + ((> (expt (- first-iteration zeroth-iteration) 2) (second qr)) + (1- first-iteration)) + (t + first-iteration)))) + ((> n 15) 4) + ((> n 8) 3) + ((> n 3) 2) + ((> n 0) 1) + ((= n 0) 0))) ;;;; miscellaneous number predicates @@ -1466,7 +1476,7 @@ the first." (do-mfuns sb!c::*untagged-unsigned-modular-class*) (do-mfuns sb!c::*untagged-signed-modular-class*) (do-mfuns sb!c::*tagged-modular-class*))) - `(progn ,@(forms))) + `(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 @@ -1486,14 +1496,9 @@ the first." (bignum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))))) -#!+x86 -(defun sb!vm::ash-left-smod30 (integer amount) - (etypecase integer - ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount))) - (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount))))) - -#!+x86-64 -(defun sb!vm::ash-left-smod61 (integer amount) - (etypecase integer - ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount))) - (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount))))) +#!+(or x86 x86-64) +(defun sb!vm::ash-left-modfx (integer amount) + (let ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))) + (etypecase integer + (fixnum (sb!c::mask-signed-field fixnum-width (ash integer amount))) + (integer (sb!c::mask-signed-field fixnum-width (ash (sb!c::mask-signed-field fixnum-width integer) amount))))))