X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=7a644b38833fa6c5d6ecdab41d5954e4c9e6fc72;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=751b6f2c40b683405e58cafee738d9f762ff3ef3;hpb=6cc71ab8ffad49f43895ad0a1df6885c81876687;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 751b6f2..7a644b3 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -211,25 +211,6 @@ ;;;; COMPLEXes -(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) - 'single-float) - ((subtypep spec 'double-float) - 'double-float) - #!+long-float - ((subtypep spec 'long-float) - 'long-float) - ((subtypep spec 'rational) - 'rational) - (t - 'real))) - (defun complex (realpart &optional (imagpart 0)) #!+sb-doc "Return a complex number with the specified real and imaginary components." @@ -284,7 +265,7 @@ ((complex rational) (sb!kernel:%imagpart number)) (float - (float 0 number)) + (* 0 number)) (t 0))) @@ -694,20 +675,74 @@ (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 (defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." + (the number number) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) T) (declare (list nlist)) @@ -716,7 +751,7 @@ (defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." - (do* ((head number (car nlist)) + (do* ((head (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -729,7 +764,7 @@ (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -738,7 +773,7 @@ (defun > (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -747,7 +782,7 @@ (defun <= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -756,7 +791,7 @@ (defun >= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -764,7 +799,8 @@ (defun max (number &rest more-numbers) #!+sb-doc - "Return the greatest of its arguments." + "Return the greatest of its arguments; among EQUALP greatest, return +the first." (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -774,7 +810,8 @@ (defun min (number &rest more-numbers) #!+sb-doc - "Return the least of its arguments." + "Return the least of its arguments; among EQUALP least, return +the first." (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -957,36 +994,6 @@ (declare (integer result))) -1)) -(defun lognand (integer1 integer2) - #!+sb-doc - "Return the complement of the logical AND of integer1 and integer2." - (lognand integer1 integer2)) - -(defun lognor (integer1 integer2) - #!+sb-doc - "Return the complement of the logical OR of integer1 and integer2." - (lognor integer1 integer2)) - -(defun logandc1 (integer1 integer2) - #!+sb-doc - "Return the logical AND of (LOGNOT integer1) and integer2." - (logandc1 integer1 integer2)) - -(defun logandc2 (integer1 integer2) - #!+sb-doc - "Return the logical AND of integer1 and (LOGNOT integer2)." - (logandc2 integer1 integer2)) - -(defun logorc1 (integer1 integer2) - #!+sb-doc - "Return the logical OR of (LOGNOT integer1) and integer2." - (logorc1 integer1 integer2)) - -(defun logorc2 (integer1 integer2) - #!+sb-doc - "Return the logical OR of integer1 and (LOGNOT integer2)." - (logorc2 integer1 integer2)) - (defun lognot (number) #!+sb-doc "Return the bit-wise logical not of integer." @@ -994,13 +1001,39 @@ (fixnum (lognot (truly-the fixnum number))) (bignum (bignum-logical-not number)))) -(macrolet ((def (name op big-op) - `(defun ,name (x y) - (number-dispatch ((x integer) (y integer)) - (bignum-cross-fixnum ,op ,big-op))))) +(macrolet ((def (name op big-op &optional doc) + `(defun ,name (integer1 integer2) + ,@(when doc + (list doc)) + (let ((x integer1) + (y integer2)) + (number-dispatch ((x integer) (y integer)) + (bignum-cross-fixnum ,op ,big-op)))))) (def two-arg-and logand bignum-logical-and) (def two-arg-ior logior bignum-logical-ior) - (def two-arg-xor logxor bignum-logical-xor)) + (def two-arg-xor logxor bignum-logical-xor) + ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must + ;; call the generic LOGNOT... + (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y)))) + (def lognand lognand + (lambda (x y) (lognot (bignum-logical-and x y))) + #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.") + (def lognor lognor + (lambda (x y) (lognot (bignum-logical-ior x y))) + #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.") + ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum + (def logandc1 logandc1 + (lambda (x y) (bignum-logical-and (bignum-logical-not x) y)) + #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.") + (def logandc2 logandc2 + (lambda (x y) (bignum-logical-and x (bignum-logical-not y))) + #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).") + (def logorc1 logorc1 + (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y)) + #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.") + (def logorc2 logorc2 + (lambda (x y) (bignum-logical-ior x (bignum-logical-not y))) + #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2).")) (defun logcount (integer) #!+sb-doc @@ -1362,21 +1395,18 @@ #. (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))))) + (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* ;; FIXME: We need to process only "toplevel" functions - unless (eq infos :good) + 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) @@ -1384,3 +1414,21 @@ for pattern = (1- (ash 1 width)) do (forms (definition name lambda-list width pattern))))) `(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 +(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 +(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)))))