From ac0bb62cb48dcba68b07e0a1eb5573de92373c7c Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 8 Dec 2003 11:28:21 +0000
Subject: [PATCH] 0.8.6.32: 	Fix for (pprint '`(lambda ,x)) bug 	...
 PPRINT-LAMBDA-LIST needs to be aware of our backquote 		implementation

---
 NEWS                        |  3 +++
 package-data-list.lisp-expr |  4 ++++
 src/code/backq.lisp         |  5 +++++
 src/code/pprint.lisp        |  9 +++++++++
 tests/pprint.impure.lisp    | 33 +++++++++++++++++++++++++++++++++
 version.lisp-expr           |  2 +-
 6 files changed, 55 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index a7342adc9..c10435ba0 100644
--- a/NEWS
+++ b/NEWS
@@ -2202,6 +2202,9 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6:
   * bug fix: buffered :DIRECTION :IO streams are less likely to become
     confused about their position.  (thanks to Adam Warner and Gerd 
     Moellmann)
+  * bug fix: Pretty printing backquoted forms with unquotations in the
+    argument list position of various code constructs such as LAMBDA
+    now works correctly.  (reported by Paul Dietz)
   * optimization: performance of string output streams is now less
     poor for multiple small sequence writes.
   * ASDF-INSTALL bug fix: now parses *PROXY* properly.  (thanks to
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 0ff51465c..c8fac4846 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -932,6 +932,10 @@ retained, possibly temporariliy, because it might be used internally."
              "PREPARE-FOR-FAST-READ-BYTE"
              "PREPARE-FOR-FAST-READ-CHAR"
 
+	     ;; reflection of our backquote implementation that the
+	     ;; pprinter needs
+	     "*BACKQ-TOKENS*"
+	     
 	     ;; hackery to help set up for cold init
              "!BEGIN-COLLECTING-COLD-INIT-FORMS"
 	     "!COLD-INIT-FORMS"
diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index 32cbdcf13..839314158 100644
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -244,4 +244,9 @@
   (set-macro-character #\, #'comma-macro))
 #+sb-xc-host (!backq-cold-init)
 
+;;; The pretty-printer needs to know about our special tokens
+(defvar *backq-tokens*
+  '(backq-comma backq-comma-at backq-comma-dot backq-list
+    backq-list* backq-append backq-nconc backq-cons backq-vector))
+
 (/show0 "done with backq.lisp")
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index d17ccfcaf..32df69b53 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1020,6 +1020,15 @@
 
 (defun pprint-lambda-list (stream lambda-list &rest noise)
   (declare (ignore noise))
+  (when (and (consp lambda-list)
+	     (member (car lambda-list) *backq-tokens*))
+    ;; if this thing looks like a backquoty thing, then we don't want
+    ;; to destructure it, we want to output it straight away.  [ this
+    ;; is the exception to the normal processing: if we did this
+    ;; generally we would find lambda lists such as (FUNCTION FOO)
+    ;; being printed as #'FOO ]  -- CSR, 2003-12-07
+    (output-object lambda-list stream)
+    (return-from pprint-lambda-list nil))
   (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
     (let ((state :required)
 	  (first t))
diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp
index 8423f9fdc..32451bedf 100644
--- a/tests/pprint.impure.lisp
+++ b/tests/pprint.impure.lisp
@@ -103,5 +103,38 @@
 	   (write '`(,  ?foo) :stream s :pretty t :readably t))
 	 "`(,?FOO)"))
 
+;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
+;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(foo ,x) :stream s :pretty t :readably t))
+	 "`(FOO ,X)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(foo ,@x) :stream s :pretty t :readably t))
+	 "`(FOO ,@X)"))
+#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently. 
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(foo ,.x) :stream s :pretty t :readably t))
+	 "`(FOO ,.X)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(lambda ,x) :stream s :pretty t :readably t))
+	 "`(LAMBDA ,X)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(lambda ,@x) :stream s :pretty t :readably t))
+	 "`(LAMBDA ,@X)"))
+#+nil ; see above
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(lambda ,.x) :stream s :pretty t :readably t))
+	 "`(LAMBDA ,.X)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(lambda (,x)) :stream s :pretty t :readably t))
+	 "`(LAMBDA (,X))"))
+
 ;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 5af4ef945..5638aacc8 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".)
-"0.8.6.31"
+"0.8.6.32"
-- 
2.11.4.GIT