X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=d525b8a38dcd1f6be93f10afc0225e044c566ed4;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=330fcdd1c085d6db477d1e974f67a55b5f9cfce2;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 330fcdd..d525b8a 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -388,7 +388,7 @@ (cond ((eql t1 0) 0) ((eql g2 1) (%make-ratio t1 (* t2 dy))) - (T (let* ((nn (truncate t1 g2)) + (t (let* ((nn (truncate t1 g2)) (t3 (truncate dy g2)) (nd (if (eql t2 1) t3 (* t2 t3)))) (if (eql nd 1) nn (%make-ratio nn nd)))))))))))) @@ -744,7 +744,7 @@ "Return T if all of its arguments are numerically equal, NIL otherwise." (the number number) (do ((nlist more-numbers (cdr nlist))) - ((atom nlist) T) + ((atom nlist) t) (declare (list nlist)) (if (not (= (car nlist) number)) (return nil)))) @@ -756,7 +756,7 @@ ((atom nlist) t) (declare (list nlist)) (unless (do* ((nl nlist (cdr nl))) - ((atom nl) T) + ((atom nl) t) (declare (list nl)) (if (= head (car nl)) (return nil))) (return nil)))) @@ -819,6 +819,15 @@ 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 @@ -838,6 +847,40 @@ the first." #!+long-float ((long-float (foreach single-float double-float)) (,op x (coerce y 'long-float))) + ((fixnum (foreach single-float double-float)) + (if (float-infinity-p y) + ,infinite-y-finite-x + ;; If the fixnum has an exact float representation, do a + ;; float comparison. Otherwise do the slow float -> ratio + ;; conversion. + (multiple-value-bind (lo hi) + (case '(dispatch-type y) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op (coerce x '(dispatch-type y)) y) + (,op x (rational y)))))) + (((foreach single-float double-float) fixnum) + (if (eql y 0) + (,op x (coerce 0 '(dispatch-type x))) + (if (float-infinity-p x) + ,infinite-x-finite-y + ;; Likewise + (multiple-value-bind (lo hi) + (case '(dispatch-type x) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op x (coerce y '(dispatch-type x))) + (,op (rational x) y)))))) (((foreach single-float double-float) double-float) (,op (coerce x 'double-float) y)) ((double-float single-float) @@ -1095,7 +1138,8 @@ the first." (defun integer-length (integer) #!+sb-doc - "Return the number of significant bits in the absolute value of integer." + "Return the number of non-sign bits in the twos-complement representation + of INTEGER." (etypecase integer (fixnum (integer-length (truly-the fixnum integer))) @@ -1161,6 +1205,18 @@ the first." (let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand newbyte mask) (logand integer (lognot mask))))) + +(defun sb!c::mask-signed-field (size integer) + #!+sb-doc + "Extract SIZE lower bits from INTEGER, considering them as a +2-complement SIZE-bits representation of a signed integer." + (cond ((zerop size) + 0) + ((logbitp (1- size) integer) + (dpb integer (byte size 0) -1)) + (t + (ldb (byte size 0) integer)))) + ;;;; BOOLE @@ -1404,7 +1460,7 @@ the first." (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-funs* + (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 @@ -1415,20 +1471,54 @@ the first." do (forms (definition name lambda-list width pattern))))) `(progn ,@(forms))) +#. +(collect ((forms)) + (flet ((definition (name lambda-list width) + `(defun ,name ,lambda-list + (flet ((prepare-argument (x) + (declare (integer x)) + (etypecase x + ((signed-byte ,width) x) + (fixnum (sb!c::mask-signed-field ,width x)) + (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))) + ;;; KLUDGE: these out-of-line definitions can't use the modular ;;; arithmetic, as that is only (currently) defined for constant ;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more ;;; discussion of this hack. -- CSR, 2003-10-09 -#!-alpha +#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or)) (defun sb!vm::ash-left-mod32 (integer amount) (etypecase integer ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount))) (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))) (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))))) -#!+alpha +#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or)) (defun sb!vm::ash-left-mod64 (integer amount) (etypecase integer ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount))) (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))) (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)))))