X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=16929b1c2b1642a6b09106e585e9451b49fb0e58;hb=7c5138fcbdb302abc563a2060493f2f0304ae902;hp=99972c80304a248775c785eb6796a3b3a9bd5d21;hpb=b0a51fec91a2196e95824165dcdb049ff6e3834b;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 99972c8..16929b1 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -675,14 +675,67 @@ (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.") +(defun ftruncate (number &optional (divisor 1)) + #!+sb-doc + "Same as TRUNCATE, but returns first value as a float." + (macrolet ((ftruncate-float (rtype) + `(let* ((float-div (coerce divisor ',rtype)) + (res (%unary-ftruncate (/ number float-div)))) + (values res + (- number + (* (coerce res ',rtype) float-div)))))) + (number-dispatch ((number real) (divisor real)) + (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) + (multiple-value-bind (q r) + (truncate number divisor) + (values (float q) r))) + (((foreach single-float double-float #!+long-float long-float) + (or rational single-float)) + (if (eql divisor 1) + (let ((res (%unary-ftruncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (ftruncate-float (dispatch-type number)))) + #!+long-float + ((long-float (or single-float double-float long-float)) + (ftruncate-float long-float)) + #!+long-float + (((foreach double-float single-float) long-float) + (ftruncate-float long-float)) + ((double-float (or single-float double-float)) + (ftruncate-float double-float)) + ((single-float double-float) + (ftruncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float #!+long-float long-float)) + (ftruncate-float (dispatch-type divisor)))))) + +(defun ffloor (number &optional (divisor 1)) + "Same as FLOOR, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (1- tru) (+ rem divisor)) + (values tru rem)))) + +(defun fceiling (number &optional (divisor 1)) + "Same as CEILING, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (+ tru 1) (- rem divisor)) + (values tru rem)))) + +;;; FIXME: this probably needs treatment similar to the use of +;;; %UNARY-FTRUNCATE for FTRUNCATE. +(defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (res rem) + (round number divisor) + (values (float res (if (floatp rem) rem 1.0)) rem))) ;;;; comparisons @@ -1108,6 +1161,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 @@ -1183,22 +1248,22 @@ the first." (defun boole (op integer1 integer2) #!+sb-doc "Bit-wise boolean function on two integers. Function chosen by OP: - 0 BOOLE-CLR - 1 BOOLE-SET - 2 BOOLE-1 - 3 BOOLE-2 - 4 BOOLE-C1 - 5 BOOLE-C2 - 6 BOOLE-AND - 7 BOOLE-IOR - 8 BOOLE-XOR - 9 BOOLE-EQV - 10 BOOLE-NAND - 11 BOOLE-NOR - 12 BOOLE-ANDC1 - 13 BOOLE-ANDC2 - 14 BOOLE-ORC1 - 15 BOOLE-ORC2" + 0 BOOLE-CLR + 1 BOOLE-SET + 2 BOOLE-1 + 3 BOOLE-2 + 4 BOOLE-C1 + 5 BOOLE-C2 + 6 BOOLE-AND + 7 BOOLE-IOR + 8 BOOLE-XOR + 9 BOOLE-EQV + 10 BOOLE-NAND + 11 BOOLE-NOR + 12 BOOLE-ANDC1 + 13 BOOLE-ANDC2 + 14 BOOLE-ORC1 + 15 BOOLE-ORC2" (case op (0 (boole 0 integer1 integer2)) (1 (boole 1 integer1 integer2)) @@ -1351,7 +1416,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 @@ -1362,6 +1427,28 @@ 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 @@ -1379,3 +1466,9 @@ the first." (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)))))