Loading code/bignum.lisp +135 −131 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.43 2007/10/10 01:09:32 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.43.4.1 2008/11/01 22:38:47 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -830,7 +830,7 @@ down to individual words.") ;;; (defun karatsuba (x y) (declare (type bignum-type x y) (optimize (speed 3) (safety 0) (debug 3))) (optimize (speed 3) (safety 0))) (flet ((power-of-two (n) ;; Compute the smallest power of two greater than or equal ;; to the given number. Loading Loading @@ -3067,74 +3067,7 @@ friends is working. ;;; ;;; These are used by BIGNUM-TRUNCATE and friends in the general case. ;;; (defvar *truncate-x*) (defvar *truncate-y*) ;;; BIGNUM-TRUNCATE -- Public. ;;; ;;; This divides x by y returning the quotient and remainder. In the general ;;; case, we shift y to setup for the algorithm, and we use two buffers to save ;;; consing intermediate values. X gets destructively modified to become the ;;; remainder, and we have to shift it to account for the initial Y shift. ;;; After we multiple bind q and r, we first fix up the signs and then return ;;; the normalized results. ;;; (defun bignum-truncate (x y) (declare (type bignum-type x y)) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x nil))) (y (if y-plusp y (negate-bignum y nil))) (len-x (%bignum-length x)) (len-y (%bignum-length y))) (multiple-value-bind (q r) (cond ((< len-y 2) (bignum-truncate-single-digit x len-x y)) ((plusp (bignum-compare y x)) (let ((res (%allocate-bignum len-x))) (dotimes (i len-x) (setf (%bignum-ref res i) (%bignum-ref x i))) (values 0 res))) (t (let ((len-x+1 (1+ len-x))) (with-bignum-buffers ((*truncate-x* len-x+1) (*truncate-y* (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift) (values (do-truncate len-x+1 len-y) ;; DO-TRUNCATE must execute first. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) (declare (type bignum-type res)) (bignum-replace res *truncate-x* :end2 len-y) (%normalize-bignum res len-y))) (t (shift-right-unaligned *truncate-x* 0 y-shift len-y ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref *truncate-x* i) y-shift)) (%normalize-bignum res res-len)) res))))))))) (let ((quotient (cond ((eq x-plusp y-plusp) q) ((typep q 'fixnum) (the fixnum (- q))) (t (negate-bignum-in-place q)))) (rem (cond (x-plusp r) ((typep r 'fixnum) (the fixnum (- r))) (t (negate-bignum-in-place r))))) (values (if (typep quotient 'fixnum) quotient (%normalize-bignum quotient (%bignum-length quotient))) (if (typep rem 'fixnum) rem (%normalize-bignum rem (%bignum-length rem)))))))) (declaim (ext:start-block bignum-truncate)) ;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. ;;; ;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes Loading Loading @@ -3162,49 +3095,10 @@ friends is working. (setf (%bignum-ref rem 0) r) (values q rem)))) ;;; DO-TRUNCATE -- Internal. ;;; ;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how ;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies ;;; *truncate-x* on each interation, and this buffer becomes our remainder. ;;; ;;; *truncate-x* definitely has at least three digits, and it has one more than ;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. ;;; (defun do-truncate (len-x len-y) (declare (type bignum-index len-x len-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. (q (%allocate-bignum (1+ len-q))) (k (1- len-q)) (y1 (%bignum-ref *truncate-y* (1- len-y))) (y2 (%bignum-ref *truncate-y* (- len-y 2))) (i (1- len-x)) (i-1 (1- i)) (i-2 (1- i-1)) (low-x-digit (- i len-y))) (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess ;; This modifies *truncate-x*. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref *truncate-x* i) (%bignum-ref *truncate-x* i-1) (%bignum-ref *truncate-x* i-2)) len-y low-x-digit)) (cond ((zerop k) (return)) (t (decf k) (decf low-x-digit) (shiftf i i-1 i-2 (1- i-2))))) q)) ;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This takes a digit guess, multiplies it by *truncate-y* for a result one ;;; greater in length than len-y, and subtracts this result from *truncate-x*. ;;; This takes a digit guess, multiplies it by truncate-y for a result one ;;; greater in length than len-y, and subtracts this result from truncate-x. ;;; Low-x-digit is the first digit of x to start the subtraction, and we know x ;;; is long enough to subtract a len-y plus one length bignum from it. Next we ;;; check the result of the subtraction, and if the high digit in x became Loading @@ -3213,9 +3107,10 @@ friends is working. ;;; subtracting one too many. Knuth shows that the guess is wrong on the order ;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. ;;; (defun try-bignum-truncate-guess (guess len-y low-x-digit) (defun try-bignum-truncate-guess (guess len-y low-x-digit truncate-x truncate-y) (declare (type bignum-index low-x-digit len-y) (type bignum-element-type guess)) (type bignum-element-type guess) (type bignum-type truncate-x truncate-y)) (let ((carry-digit 0) (borrow 1) (i low-x-digit)) Loading @@ -3225,23 +3120,23 @@ friends is working. ;; Multiply guess and divisor, subtracting from dividend simultaneously. (dotimes (j len-y) (multiple-value-bind (high-digit low-digit) (%multiply-and-add guess (%bignum-ref *truncate-y* j) (%multiply-and-add guess (%bignum-ref truncate-y j) carry-digit) (declare (type bignum-element-type high-digit low-digit)) (setf carry-digit high-digit) (multiple-value-bind (x temp-borrow) (%subtract-with-borrow (%bignum-ref *truncate-x* i) (%subtract-with-borrow (%bignum-ref truncate-x i) low-digit borrow) (declare (type bignum-element-type x) (fixnum temp-borrow)) (setf (%bignum-ref *truncate-x* i) x) (setf (%bignum-ref truncate-x i) x) (setf borrow temp-borrow))) (incf i)) (setf (%bignum-ref *truncate-x* i) (%subtract-with-borrow (%bignum-ref *truncate-x* i) (setf (%bignum-ref truncate-x i) (%subtract-with-borrow (%bignum-ref truncate-x i) carry-digit borrow)) ;; See if guess is off by one, adding one Y back in if necessary. (cond ((%digit-0-or-plusp (%bignum-ref *truncate-x* i)) (cond ((%digit-0-or-plusp (%bignum-ref truncate-x i)) guess) (t ;; If subtraction has negative result, add one divisor value back Loading @@ -3250,17 +3145,58 @@ friends is working. (carry 0)) (dotimes (j len-y) (multiple-value-bind (v k) (%add-with-carry (%bignum-ref *truncate-y* j) (%bignum-ref *truncate-x* i) (%add-with-carry (%bignum-ref truncate-y j) (%bignum-ref truncate-x i) carry) (declare (type bignum-element-type v)) (setf (%bignum-ref *truncate-x* i) v) (setf (%bignum-ref truncate-x i) v) (setf carry k)) (incf i)) (setf (%bignum-ref *truncate-x* i) (%add-with-carry (%bignum-ref *truncate-x* i) 0 carry))) (setf (%bignum-ref truncate-x i) (%add-with-carry (%bignum-ref truncate-x i) 0 carry))) (%subtract-with-borrow guess 1 1))))) ;;; DO-TRUNCATE -- Internal. ;;; ;;; This divides truncate-x by truncate-y, and len-x and len-y tell us how ;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies ;;; truncate-x on each interation, and this buffer becomes our remainder. ;;; ;;; truncate-x definitely has at least three digits, and it has one more than ;;; truncate-y. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. ;;; (defun do-truncate (len-x len-y truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type bignum-type truncate-x truncate-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. (q (%allocate-bignum (1+ len-q))) (k (1- len-q)) (y1 (%bignum-ref truncate-y (1- len-y))) (y2 (%bignum-ref truncate-y (- len-y 2))) (i (1- len-x)) (i-1 (1- i)) (i-2 (1- i-1)) (low-x-digit (- i len-y))) (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess ;; This modifies truncate-x. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref truncate-x i) (%bignum-ref truncate-x i-1) (%bignum-ref truncate-x i-2)) len-y low-x-digit truncate-x truncate-y)) (cond ((zerop k) (return)) (t (decf k) (decf low-x-digit) (shiftf i i-1 i-2 (1- i-2))))) q)) ;;; BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This returns a guess for the next division step. Y1 is the highest y Loading Loading @@ -3325,6 +3261,7 @@ friends is working. ;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit ;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. ;;; (declaim (inline shift-y-for-truncate)) (defun shift-y-for-truncate (y) (let* ((len (%bignum-length y)) (last (%bignum-ref y (1- len)))) Loading @@ -3336,18 +3273,84 @@ friends is working. ;;; ;;; Stores two bignums into the truncation bignum buffers, shifting them on the ;;; way in. This assumes x and y are positive and at least two in length, and ;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y. ;;; it assumes truncate-x and truncate-y are one digit longer than x and y. ;;; (defun shift-and-store-truncate-buffers (x len-x y len-y shift) (defun shift-and-store-truncate-buffers (x len-x y len-y shift truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type (integer 0 (#.digit-size)) shift)) (type (integer 0 (#.digit-size)) shift) (type bignum-type truncate-x truncate-y)) (cond ((zerop shift) (bignum-replace *truncate-x* x :end1 len-x) (bignum-replace *truncate-y* y :end1 len-y)) (bignum-replace truncate-x x :end1 len-x) (bignum-replace truncate-y y :end1 len-y)) (t (bignum-ashift-left-unaligned x 0 shift (1+ len-x) truncate-x) (bignum-ashift-left-unaligned y 0 shift (1+ len-y) truncate-y)))) ;;; BIGNUM-TRUNCATE -- Public. ;;; ;;; This divides x by y returning the quotient and remainder. In the general ;;; case, we shift y to setup for the algorithm, and we use two buffers to save ;;; consing intermediate values. X gets destructively modified to become the ;;; remainder, and we have to shift it to account for the initial Y shift. ;;; After we multiple bind q and r, we first fix up the signs and then return ;;; the normalized results. ;;; (defun bignum-truncate (x y) (declare (type bignum-type x y) (optimize (speed 3))) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x nil))) (y (if y-plusp y (negate-bignum y nil))) (len-x (%bignum-length x)) (len-y (%bignum-length y))) (multiple-value-bind (q r) (cond ((< len-y 2) (bignum-truncate-single-digit x len-x y)) ((plusp (bignum-compare y x)) (let ((res (%allocate-bignum len-x))) (dotimes (i len-x) (setf (%bignum-ref res i) (%bignum-ref x i))) (values 0 res))) (t (let ((len-x+1 (1+ len-x))) (with-bignum-buffers ((truncate-x len-x+1) (truncate-y (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift truncate-x truncate-y) (values (do-truncate len-x+1 len-y truncate-x truncate-y) ;; DO-TRUNCATE must execute first. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) (declare (type bignum-type res)) (bignum-replace res truncate-x :end2 len-y) (%normalize-bignum res len-y))) (t (bignum-ashift-left-unaligned x 0 shift (1+ len-x) *truncate-x*) (bignum-ashift-left-unaligned y 0 shift (1+ len-y) *truncate-y*)))) (shift-right-unaligned truncate-x 0 y-shift len-y ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref truncate-x i) y-shift)) (%normalize-bignum res res-len)) res))))))))) (let ((quotient (cond ((eq x-plusp y-plusp) q) ((typep q 'fixnum) (the fixnum (- q))) (t (negate-bignum-in-place q)))) (rem (cond (x-plusp r) ((typep r 'fixnum) (the fixnum (- r))) (t (negate-bignum-in-place r))))) (values (if (typep quotient 'fixnum) quotient (%normalize-bignum quotient (%bignum-length quotient))) (if (typep rem 'fixnum) rem (%normalize-bignum rem (%bignum-length rem)))))))) (declaim (ext:end-block)) ;;;; %FLOOR primitive for BIGNUM-TRUNCATE. Loading @@ -3365,6 +3368,7 @@ friends is working. ;;; %FLOOR for machines with a 32x32 divider. ;;; #+32x16-divide (declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry 32x16-divide 32x16-multiply 32x16-multiply-split)) Loading code/eval.lisp +12 −1 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.43 2006/12/19 10:50:57 cshapiro Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.43.4.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -230,6 +230,17 @@ (dolist (x (butlast (rest exp)) (eval (car (last exp)))) (eval x)))) ((eval-when) (when (plusp args) (let* ((situations (second exp)) (bad-situations (if (listp situations) (set-difference situations '(compile load eval :compile-toplevel :load-toplevel :execute)) situations))) (when (or (not (listp situations)) bad-situations) (warn "Bad Eval-When situation list: ~S." bad-situations)))) (if (and (> args 0) (or (member 'eval (second exp)) (member :execute (second exp)))) Loading code/exports.lisp +5 −3 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.267.2.4 2008/09/03 16:34:31 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.267.2.5 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -307,7 +307,8 @@ #+(or svr4 bsd linux) "O_NDELAY" "CHECK" "UNIX-RECVFROM" "UNIX-SENDTO" "UNIX-SHUTDOWN") "UNIX-RECVFROM" "UNIX-SENDTO" "UNIX-SHUTDOWN" "UNIX-OPENPTY") #+(or svr4 linux) (:export "EADDRINUSE" "EADDRNOTAVAIL" "EADV" "EAFNOSUPPORT" "EALREADY" "EBADE" "EBADFD" "EBADMSG" "EBADR" "EBADRQC" Loading Loading @@ -362,7 +363,8 @@ "USER-INFO-SHELL" "USER-INFO-PASSWORD" "USER-INFO-UID" "GROUP-INFO-GID" "USER-INFO" "USER-INFO-NAME" "USER-INFO-GID" "GROUP-INFO-MEMBERS" "UNIX-GETGRGID" "USER-INFO-GECOS" "GROUP-INFO-NAME")) "GROUP-INFO-NAME" "UNIX-GETGRNAM")) (defpackage "FORMAT") Loading code/float.lisp +26 −2 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.41 2008/04/15 16:31:58 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.41.2.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -348,7 +348,31 @@ #+long-float ((long-float) (frob vm:long-float-digits vm:long-float-bias integer-decode-long-denorm))))) integer-decode-long-denorm)) #+double-double ((double-double-float) ;; What exactly is the precision for a double-double? We make ;; it the sum of the precisions of the two components. (let ((hi (double-double-hi f))) (cond ((zerop hi) ;; ANSI CL says the precision is 0 0) ((< (abs hi) (scale-float least-positive-normalized-double-float 53)) ;; For every power of 2 below this, we lose a bit of ;; precision. More or less. (let ((cutoff (nth-value 1 (decode-float (scale-float least-positive-normalized-double-float 53))))) (multiple-value-bind (f exp) (decode-float hi) (declare (ignore f)) (- 106 (- cutoff exp))))) (t ;; Normally we have 106 bits of precision (twice the ;; double-float precision) 106))))))) #+nil Loading code/foreign.lisp +2 −2 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.54 2006/04/26 20:49:23 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.54.12.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -845,7 +845,7 @@ environment passed to Lisp." (when (atom files) (when verbose (format t ";;; Opening as shared library ~A ...~%" files)) (multiple-value-bind (ok &optional error-string) (multiple-value-bind (ok error-string) (load-object-file files) (cond (ok (when verbose Loading Loading
code/bignum.lisp +135 −131 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.43 2007/10/10 01:09:32 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.43.4.1 2008/11/01 22:38:47 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -830,7 +830,7 @@ down to individual words.") ;;; (defun karatsuba (x y) (declare (type bignum-type x y) (optimize (speed 3) (safety 0) (debug 3))) (optimize (speed 3) (safety 0))) (flet ((power-of-two (n) ;; Compute the smallest power of two greater than or equal ;; to the given number. Loading Loading @@ -3067,74 +3067,7 @@ friends is working. ;;; ;;; These are used by BIGNUM-TRUNCATE and friends in the general case. ;;; (defvar *truncate-x*) (defvar *truncate-y*) ;;; BIGNUM-TRUNCATE -- Public. ;;; ;;; This divides x by y returning the quotient and remainder. In the general ;;; case, we shift y to setup for the algorithm, and we use two buffers to save ;;; consing intermediate values. X gets destructively modified to become the ;;; remainder, and we have to shift it to account for the initial Y shift. ;;; After we multiple bind q and r, we first fix up the signs and then return ;;; the normalized results. ;;; (defun bignum-truncate (x y) (declare (type bignum-type x y)) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x nil))) (y (if y-plusp y (negate-bignum y nil))) (len-x (%bignum-length x)) (len-y (%bignum-length y))) (multiple-value-bind (q r) (cond ((< len-y 2) (bignum-truncate-single-digit x len-x y)) ((plusp (bignum-compare y x)) (let ((res (%allocate-bignum len-x))) (dotimes (i len-x) (setf (%bignum-ref res i) (%bignum-ref x i))) (values 0 res))) (t (let ((len-x+1 (1+ len-x))) (with-bignum-buffers ((*truncate-x* len-x+1) (*truncate-y* (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift) (values (do-truncate len-x+1 len-y) ;; DO-TRUNCATE must execute first. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) (declare (type bignum-type res)) (bignum-replace res *truncate-x* :end2 len-y) (%normalize-bignum res len-y))) (t (shift-right-unaligned *truncate-x* 0 y-shift len-y ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref *truncate-x* i) y-shift)) (%normalize-bignum res res-len)) res))))))))) (let ((quotient (cond ((eq x-plusp y-plusp) q) ((typep q 'fixnum) (the fixnum (- q))) (t (negate-bignum-in-place q)))) (rem (cond (x-plusp r) ((typep r 'fixnum) (the fixnum (- r))) (t (negate-bignum-in-place r))))) (values (if (typep quotient 'fixnum) quotient (%normalize-bignum quotient (%bignum-length quotient))) (if (typep rem 'fixnum) rem (%normalize-bignum rem (%bignum-length rem)))))))) (declaim (ext:start-block bignum-truncate)) ;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. ;;; ;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes Loading Loading @@ -3162,49 +3095,10 @@ friends is working. (setf (%bignum-ref rem 0) r) (values q rem)))) ;;; DO-TRUNCATE -- Internal. ;;; ;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how ;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies ;;; *truncate-x* on each interation, and this buffer becomes our remainder. ;;; ;;; *truncate-x* definitely has at least three digits, and it has one more than ;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. ;;; (defun do-truncate (len-x len-y) (declare (type bignum-index len-x len-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. (q (%allocate-bignum (1+ len-q))) (k (1- len-q)) (y1 (%bignum-ref *truncate-y* (1- len-y))) (y2 (%bignum-ref *truncate-y* (- len-y 2))) (i (1- len-x)) (i-1 (1- i)) (i-2 (1- i-1)) (low-x-digit (- i len-y))) (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess ;; This modifies *truncate-x*. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref *truncate-x* i) (%bignum-ref *truncate-x* i-1) (%bignum-ref *truncate-x* i-2)) len-y low-x-digit)) (cond ((zerop k) (return)) (t (decf k) (decf low-x-digit) (shiftf i i-1 i-2 (1- i-2))))) q)) ;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This takes a digit guess, multiplies it by *truncate-y* for a result one ;;; greater in length than len-y, and subtracts this result from *truncate-x*. ;;; This takes a digit guess, multiplies it by truncate-y for a result one ;;; greater in length than len-y, and subtracts this result from truncate-x. ;;; Low-x-digit is the first digit of x to start the subtraction, and we know x ;;; is long enough to subtract a len-y plus one length bignum from it. Next we ;;; check the result of the subtraction, and if the high digit in x became Loading @@ -3213,9 +3107,10 @@ friends is working. ;;; subtracting one too many. Knuth shows that the guess is wrong on the order ;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. ;;; (defun try-bignum-truncate-guess (guess len-y low-x-digit) (defun try-bignum-truncate-guess (guess len-y low-x-digit truncate-x truncate-y) (declare (type bignum-index low-x-digit len-y) (type bignum-element-type guess)) (type bignum-element-type guess) (type bignum-type truncate-x truncate-y)) (let ((carry-digit 0) (borrow 1) (i low-x-digit)) Loading @@ -3225,23 +3120,23 @@ friends is working. ;; Multiply guess and divisor, subtracting from dividend simultaneously. (dotimes (j len-y) (multiple-value-bind (high-digit low-digit) (%multiply-and-add guess (%bignum-ref *truncate-y* j) (%multiply-and-add guess (%bignum-ref truncate-y j) carry-digit) (declare (type bignum-element-type high-digit low-digit)) (setf carry-digit high-digit) (multiple-value-bind (x temp-borrow) (%subtract-with-borrow (%bignum-ref *truncate-x* i) (%subtract-with-borrow (%bignum-ref truncate-x i) low-digit borrow) (declare (type bignum-element-type x) (fixnum temp-borrow)) (setf (%bignum-ref *truncate-x* i) x) (setf (%bignum-ref truncate-x i) x) (setf borrow temp-borrow))) (incf i)) (setf (%bignum-ref *truncate-x* i) (%subtract-with-borrow (%bignum-ref *truncate-x* i) (setf (%bignum-ref truncate-x i) (%subtract-with-borrow (%bignum-ref truncate-x i) carry-digit borrow)) ;; See if guess is off by one, adding one Y back in if necessary. (cond ((%digit-0-or-plusp (%bignum-ref *truncate-x* i)) (cond ((%digit-0-or-plusp (%bignum-ref truncate-x i)) guess) (t ;; If subtraction has negative result, add one divisor value back Loading @@ -3250,17 +3145,58 @@ friends is working. (carry 0)) (dotimes (j len-y) (multiple-value-bind (v k) (%add-with-carry (%bignum-ref *truncate-y* j) (%bignum-ref *truncate-x* i) (%add-with-carry (%bignum-ref truncate-y j) (%bignum-ref truncate-x i) carry) (declare (type bignum-element-type v)) (setf (%bignum-ref *truncate-x* i) v) (setf (%bignum-ref truncate-x i) v) (setf carry k)) (incf i)) (setf (%bignum-ref *truncate-x* i) (%add-with-carry (%bignum-ref *truncate-x* i) 0 carry))) (setf (%bignum-ref truncate-x i) (%add-with-carry (%bignum-ref truncate-x i) 0 carry))) (%subtract-with-borrow guess 1 1))))) ;;; DO-TRUNCATE -- Internal. ;;; ;;; This divides truncate-x by truncate-y, and len-x and len-y tell us how ;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies ;;; truncate-x on each interation, and this buffer becomes our remainder. ;;; ;;; truncate-x definitely has at least three digits, and it has one more than ;;; truncate-y. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. ;;; (defun do-truncate (len-x len-y truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type bignum-type truncate-x truncate-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. (q (%allocate-bignum (1+ len-q))) (k (1- len-q)) (y1 (%bignum-ref truncate-y (1- len-y))) (y2 (%bignum-ref truncate-y (- len-y 2))) (i (1- len-x)) (i-1 (1- i)) (i-2 (1- i-1)) (low-x-digit (- i len-y))) (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess ;; This modifies truncate-x. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref truncate-x i) (%bignum-ref truncate-x i-1) (%bignum-ref truncate-x i-2)) len-y low-x-digit truncate-x truncate-y)) (cond ((zerop k) (return)) (t (decf k) (decf low-x-digit) (shiftf i i-1 i-2 (1- i-2))))) q)) ;;; BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This returns a guess for the next division step. Y1 is the highest y Loading Loading @@ -3325,6 +3261,7 @@ friends is working. ;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit ;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. ;;; (declaim (inline shift-y-for-truncate)) (defun shift-y-for-truncate (y) (let* ((len (%bignum-length y)) (last (%bignum-ref y (1- len)))) Loading @@ -3336,18 +3273,84 @@ friends is working. ;;; ;;; Stores two bignums into the truncation bignum buffers, shifting them on the ;;; way in. This assumes x and y are positive and at least two in length, and ;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y. ;;; it assumes truncate-x and truncate-y are one digit longer than x and y. ;;; (defun shift-and-store-truncate-buffers (x len-x y len-y shift) (defun shift-and-store-truncate-buffers (x len-x y len-y shift truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type (integer 0 (#.digit-size)) shift)) (type (integer 0 (#.digit-size)) shift) (type bignum-type truncate-x truncate-y)) (cond ((zerop shift) (bignum-replace *truncate-x* x :end1 len-x) (bignum-replace *truncate-y* y :end1 len-y)) (bignum-replace truncate-x x :end1 len-x) (bignum-replace truncate-y y :end1 len-y)) (t (bignum-ashift-left-unaligned x 0 shift (1+ len-x) truncate-x) (bignum-ashift-left-unaligned y 0 shift (1+ len-y) truncate-y)))) ;;; BIGNUM-TRUNCATE -- Public. ;;; ;;; This divides x by y returning the quotient and remainder. In the general ;;; case, we shift y to setup for the algorithm, and we use two buffers to save ;;; consing intermediate values. X gets destructively modified to become the ;;; remainder, and we have to shift it to account for the initial Y shift. ;;; After we multiple bind q and r, we first fix up the signs and then return ;;; the normalized results. ;;; (defun bignum-truncate (x y) (declare (type bignum-type x y) (optimize (speed 3))) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x nil))) (y (if y-plusp y (negate-bignum y nil))) (len-x (%bignum-length x)) (len-y (%bignum-length y))) (multiple-value-bind (q r) (cond ((< len-y 2) (bignum-truncate-single-digit x len-x y)) ((plusp (bignum-compare y x)) (let ((res (%allocate-bignum len-x))) (dotimes (i len-x) (setf (%bignum-ref res i) (%bignum-ref x i))) (values 0 res))) (t (let ((len-x+1 (1+ len-x))) (with-bignum-buffers ((truncate-x len-x+1) (truncate-y (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift truncate-x truncate-y) (values (do-truncate len-x+1 len-y truncate-x truncate-y) ;; DO-TRUNCATE must execute first. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) (declare (type bignum-type res)) (bignum-replace res truncate-x :end2 len-y) (%normalize-bignum res len-y))) (t (bignum-ashift-left-unaligned x 0 shift (1+ len-x) *truncate-x*) (bignum-ashift-left-unaligned y 0 shift (1+ len-y) *truncate-y*)))) (shift-right-unaligned truncate-x 0 y-shift len-y ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref truncate-x i) y-shift)) (%normalize-bignum res res-len)) res))))))))) (let ((quotient (cond ((eq x-plusp y-plusp) q) ((typep q 'fixnum) (the fixnum (- q))) (t (negate-bignum-in-place q)))) (rem (cond (x-plusp r) ((typep r 'fixnum) (the fixnum (- r))) (t (negate-bignum-in-place r))))) (values (if (typep quotient 'fixnum) quotient (%normalize-bignum quotient (%bignum-length quotient))) (if (typep rem 'fixnum) rem (%normalize-bignum rem (%bignum-length rem)))))))) (declaim (ext:end-block)) ;;;; %FLOOR primitive for BIGNUM-TRUNCATE. Loading @@ -3365,6 +3368,7 @@ friends is working. ;;; %FLOOR for machines with a 32x32 divider. ;;; #+32x16-divide (declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry 32x16-divide 32x16-multiply 32x16-multiply-split)) Loading
code/eval.lisp +12 −1 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.43 2006/12/19 10:50:57 cshapiro Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.43.4.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -230,6 +230,17 @@ (dolist (x (butlast (rest exp)) (eval (car (last exp)))) (eval x)))) ((eval-when) (when (plusp args) (let* ((situations (second exp)) (bad-situations (if (listp situations) (set-difference situations '(compile load eval :compile-toplevel :load-toplevel :execute)) situations))) (when (or (not (listp situations)) bad-situations) (warn "Bad Eval-When situation list: ~S." bad-situations)))) (if (and (> args 0) (or (member 'eval (second exp)) (member :execute (second exp)))) Loading
code/exports.lisp +5 −3 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.267.2.4 2008/09/03 16:34:31 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.267.2.5 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -307,7 +307,8 @@ #+(or svr4 bsd linux) "O_NDELAY" "CHECK" "UNIX-RECVFROM" "UNIX-SENDTO" "UNIX-SHUTDOWN") "UNIX-RECVFROM" "UNIX-SENDTO" "UNIX-SHUTDOWN" "UNIX-OPENPTY") #+(or svr4 linux) (:export "EADDRINUSE" "EADDRNOTAVAIL" "EADV" "EAFNOSUPPORT" "EALREADY" "EBADE" "EBADFD" "EBADMSG" "EBADR" "EBADRQC" Loading Loading @@ -362,7 +363,8 @@ "USER-INFO-SHELL" "USER-INFO-PASSWORD" "USER-INFO-UID" "GROUP-INFO-GID" "USER-INFO" "USER-INFO-NAME" "USER-INFO-GID" "GROUP-INFO-MEMBERS" "UNIX-GETGRGID" "USER-INFO-GECOS" "GROUP-INFO-NAME")) "GROUP-INFO-NAME" "UNIX-GETGRNAM")) (defpackage "FORMAT") Loading
code/float.lisp +26 −2 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.41 2008/04/15 16:31:58 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.41.2.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -348,7 +348,31 @@ #+long-float ((long-float) (frob vm:long-float-digits vm:long-float-bias integer-decode-long-denorm))))) integer-decode-long-denorm)) #+double-double ((double-double-float) ;; What exactly is the precision for a double-double? We make ;; it the sum of the precisions of the two components. (let ((hi (double-double-hi f))) (cond ((zerop hi) ;; ANSI CL says the precision is 0 0) ((< (abs hi) (scale-float least-positive-normalized-double-float 53)) ;; For every power of 2 below this, we lose a bit of ;; precision. More or less. (let ((cutoff (nth-value 1 (decode-float (scale-float least-positive-normalized-double-float 53))))) (multiple-value-bind (f exp) (decode-float hi) (declare (ignore f)) (- 106 (- cutoff exp))))) (t ;; Normally we have 106 bits of precision (twice the ;; double-float precision) 106))))))) #+nil Loading
code/foreign.lisp +2 −2 Original line number Diff line number Diff line Loading @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.54 2006/04/26 20:49:23 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.54.12.1 2008/11/01 22:40:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; Loading Loading @@ -845,7 +845,7 @@ environment passed to Lisp." (when (atom files) (when verbose (format t ";;; Opening as shared library ~A ...~%" files)) (multiple-value-bind (ok &optional error-string) (multiple-value-bind (ok error-string) (load-object-file files) (cond (ok (when verbose Loading