From 06fbb54c129639135c270025ef8c3303fe9a026b Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 30 Aug 2010 15:06:46 +0000
Subject: [PATCH] 1.0.42.4: fix compiler-macros for WRITE and WRITE-TO-STRING

 * Based on patch by Stas Boukarev, lp#598374 and lp#581564.

 * Handle output-stream designators in WRITE.

 * Avoid name capture in WRITE-TO-STRING.
---
 NEWS                    |    5 +++++
 src/code/print.lisp     |    9 +++++----
 tests/print.impure.lisp |   18 ++++++++++++++++++
 version.lisp-expr       |    2 +-
 4 files changed, 29 insertions(+), 5 deletions(-)

diff --git a/NEWS b/NEWS
index c97dbeb..5d8ddb1 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,11 @@ changes relative to sbcl-1.0.42
     was non-negative. (lp#622958)
   * bug fix: DOTIMES accepted literal non-integer reals. (lp#619393, thanks to
     Roman Marynchak)
+  * bug fix: WRITE-TO-STRING compiler macro binding special variable names,
+    breaking code that tried to write the value of a printer control variable.
+    (lp#581564, thanks to Stas Boukarev)
+  * bug fix: WRITE compiler macro did not handle output stream designators
+    correctly. (lp#598374, thanks to Stas Boukarev)
 
 changes in sbcl-1.0.42 relative to sbcl-1.0.41
   * build changes
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 0e989ca..fd90bd2 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -196,7 +196,7 @@
     (once-only ((object object))
       `(let ,(nreverse bind)
          ,@(when ignore `((declare (ignore ,@ignore))))
-         (output-object ,object stream)
+         (output-object ,object (out-synonym-of stream))
          ,object))))
 
 (defun prin1 (object &optional stream)
@@ -277,9 +277,10 @@
           (push variable ignore))
         (push (list variable value) bind)))
     (if bind
-        `(let ,(nreverse bind)
-           ,@(when ignore `((declare (ignore ,@ignore))))
-           (stringify-object ,object))
+        (once-only ((object object))
+          `(let ,(nreverse bind)
+             ,@(when ignore `((declare (ignore ,@ignore))))
+             (stringify-object ,object)))
         `(stringify-object ,object))))
 
 (defun prin1-to-string (object)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 37e5936..c773e76 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -483,4 +483,22 @@
   (assert (= 123 (funcall (compile nil (lambda ()
                                          (write 123)))))))
 
+(with-test (:name :write/write-to-string-compiler-macro-lp/598374+581564)
+  (let ((test (compile nil
+                       `(lambda (object &optional output-stream)
+                          (write object
+                                 :stream output-stream)))))
+    (assert (equal "(HELLO WORLD)"
+                   (with-output-to-string (*standard-output*)
+                     (let ((list '(hello world)))
+                       (assert (eq list (funcall test list)))))))
+    (assert (equal "12"
+                   (with-output-to-string (*standard-output*)
+                     (assert (eql 12 (funcall test 12)))))))
+  (let ((test (compile nil
+                       `(lambda ()
+                          (let ((*print-length* 42))
+                            (write-to-string *print-length* :length nil))))))
+    (assert (equal "42" (funcall test)))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index e7339d5..817b46a 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.42.3"
+"1.0.42.4"
-- 
1.7.10.4