X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbignum.lisp;h=af0f06ac8869396679da44bf249c543951f0817d;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=7f54a05fa99ccbe6e61d901785db4b79fc7651e4;hpb=b6aed043108ac99142b124306a346d18a99d21ef;p=sbcl.git diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index 7f54a05..af0f06a 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -194,7 +194,7 @@ (%lognot digit)) ;;; Each of these does the digit-size unsigned op. -#!-sb-fluid (declaim (inline %logand %logior %logxor)) +(declaim (inline %logand %logior %logxor)) (defun %logand (a b) (declare (type bignum-element-type a b)) (logand a b)) @@ -270,7 +270,7 @@ ;;; These take two digit-size quantities and compare or contrast them ;;; without wasting time with incorrect type checking. -#!-sb-fluid (declaim (inline %digit-compare %digit-greater)) +(declaim (inline %digit-compare %digit-greater)) (defun %digit-compare (x y) (= x y)) (defun %digit-greater (x y) @@ -339,14 +339,7 @@ ;;; function to call that fixes up the result returning any useful values, such ;;; as the result. This macro may evaluate its arguments more than once. (sb!xc:defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun) - (let ((borrow (gensym)) - (a-digit (gensym)) - (a-sign (gensym)) - (b-digit (gensym)) - (b-sign (gensym)) - (i (gensym)) - (v (gensym)) - (k (gensym))) + (with-unique-names (borrow a-digit a-sign b-digit b-sign i v k) `(let* ((,borrow 1) (,a-sign (%sign-digit ,a ,len-a)) (,b-sign (%sign-digit ,b ,len-b))) @@ -482,38 +475,30 @@ from-end) (sb!int:once-only ((n-dest dest) (n-src src)) - (let ((n-start1 (gensym)) - (n-end1 (gensym)) - (n-start2 (gensym)) - (n-end2 (gensym)) - (i1 (gensym)) - (i2 (gensym)) - (end1 (or end1 `(%bignum-length ,n-dest))) - (end2 (or end2 `(%bignum-length ,n-src)))) - (if from-end - `(let ((,n-start1 ,start1) - (,n-start2 ,start2)) - (do ((,i1 (1- ,end1) (1- ,i1)) - (,i2 (1- ,end2) (1- ,i2))) - ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) - (declare (fixnum ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2)))) - (if (eql start1 start2) - `(let ((,n-end1 (min ,end1 ,end2))) - (do ((,i1 ,start1 (1+ ,i1))) - ((>= ,i1 ,n-end1)) - (declare (type bignum-index ,i1)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i1)))) - `(let ((,n-end1 ,end1) - (,n-end2 ,end2)) - (do ((,i1 ,start1 (1+ ,i1)) - (,i2 ,start2 (1+ ,i2))) - ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) - (declare (type bignum-index ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2))))))))) + (with-unique-names (n-start1 n-end1 n-start2 n-end2 i1 i2) + (let ((end1 (or end1 `(%bignum-length ,n-dest))) + (end2 (or end2 `(%bignum-length ,n-src)))) + (if from-end + `(let ((,n-start1 ,start1) + (,n-start2 ,start2)) + (do ((,i1 (1- ,end1) (1- ,i1)) + (,i2 (1- ,end2) (1- ,i2))) + ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) + (declare (fixnum ,i1 ,i2)) + (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))) + (if (eql start1 start2) + `(let ((,n-end1 (min ,end1 ,end2))) + (do ((,i1 ,start1 (1+ ,i1))) + ((>= ,i1 ,n-end1)) + (declare (type bignum-index ,i1)) + (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i1)))) + `(let ((,n-end1 ,end1) + (,n-end2 ,end2)) + (do ((,i1 ,start1 (1+ ,i1)) + (,i2 ,start2 (1+ ,i2))) + ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) + (declare (type bignum-index ,i1 ,i2)) + (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))))))))) (sb!xc:defmacro with-bignum-buffers (specs &body body) #!+sb-doc @@ -792,6 +777,7 @@ (setf u-len (make-gcd-bignum-odd u u-len)) (rotatef u v) (rotatef u-len v-len)) + (bignum-abs-buffer u u-len) (setf u (copy-bignum u u-len)) (let ((n (bignum-mod-gcd v1 u))) (ash (bignum-mod-gcd u1 (if (fixnump n) @@ -908,13 +894,9 @@ ;;; This negates bignum-len digits of bignum, storing the resulting digits into ;;; result (possibly EQ to bignum) and returning whatever end-carry there is. -(sb!xc:defmacro bignum-negate-loop (bignum - bignum-len - &optional (result nil resultp)) - (let ((carry (gensym)) - (end (gensym)) - (value (gensym)) - (last (gensym))) +(sb!xc:defmacro bignum-negate-loop + (bignum bignum-len &optional (result nil resultp)) + (with-unique-names (carry end value last) `(let* (,@(if (not resultp) `(,last)) (,carry (multiple-value-bind (,value ,carry) @@ -1586,24 +1568,27 @@ (declare (type bignum-element-type y)) (if (not (logtest y (1- y))) ;; Y is a power of two. - (if (= y 1) - ;; SHIFT-RIGHT-UNALIGNED won't do the right thing - ;; with a shift count of 0, so special case this. - ;; We could probably get away with (VALUES X 0) - ;; here, but it's not clear that some of the - ;; normalization logic further down would avoid - ;; mutilating X. Just go ahead and cons, consing's - ;; cheap. - (values (copy-bignum x len-x) 0) - (let ((n-bits (1- (integer-length y)))) - (values - (shift-right-unaligned x 0 n-bits len-x - ((= j res-len-1) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref x i) n-bits)) - res) - res) - (logand (%bignum-ref x 0) (1- y))))) + ;; SHIFT-RIGHT-UNALIGNED won't do the right thing + ;; with a shift count of 0 or -1, so special case this. + (cond ((= y 0) + (error 'division-by-zero)) + ((= y 1) + ;; We could probably get away with (VALUES X 0) + ;; here, but it's not clear that some of the + ;; normalization logic further down would avoid + ;; mutilating X. Just go ahead and cons, consing's + ;; cheap. + (values (copy-bignum x len-x) 0)) + (t + (let ((n-bits (1- (integer-length y)))) + (values + (shift-right-unaligned x 0 n-bits len-x + ((= j res-len-1) + (setf (%bignum-ref res j) + (%ashr (%bignum-ref x i) n-bits)) + res) + res) + (logand (%bignum-ref x 0) (1- y)))))) (do ((i (1- len-x) (1- i)) (q (%allocate-bignum len-x)) (r 0))