Commit 2cad8ceb authored by rtoy's avatar rtoy
Browse files

Sync to snapshot 2008-11.

parent 3327b6aa
Loading
Loading
Loading
Loading
+135 −131
Original line number Diff line number Diff line
@@ -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 $")
;;;
;;; **********************************************************************
;;;
@@ -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.
@@ -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
@@ -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
@@ -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))
@@ -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
@@ -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
@@ -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))))
@@ -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.
@@ -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))

+12 −1
Original line number Diff line number Diff line
@@ -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 $")
;;;
;;; **********************************************************************
;;;
@@ -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))))
+5 −3
Original line number Diff line number Diff line
@@ -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 $")
;;;
;;; **********************************************************************
;;;
@@ -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"
@@ -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")

+26 −2
Original line number Diff line number Diff line
@@ -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 $")
;;;
;;; **********************************************************************
;;;
@@ -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
+2 −2
Original line number Diff line number Diff line
@@ -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 $")
;;;
;;; **********************************************************************
;;;
@@ -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