X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpprint.impure.lisp;h=66efdc151f5a6aaf742d859719dc8eafb3100737;hb=9b55754d5328a5f44ee224d32865fc8dadee123b;hp=216c9e099312396a0d023c87837968f9bd54baa1;hpb=165bb53b405ab95ce76615ab77cee8284df0a36e;p=sbcl.git

diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp
index 216c9e0..66efdc1 100644
--- a/tests/pprint.impure.lisp
+++ b/tests/pprint.impure.lisp
@@ -67,5 +67,102 @@
 ;;; way to make an automated test:
 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
 
+;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
+;;; PPRINT-LOGICAL-BLOCK may be complex strings
+(let ((list '(1 2 3))
+      (prefix (make-array 2
+                          :element-type 'character
+                          :displaced-to ";x"
+                          :fill-pointer 1))
+      (suffix (make-array 2
+                          :element-type 'character
+                          :displaced-to ">xy"
+                          :displaced-index-offset 1
+                          :fill-pointer 1)))
+  (assert (equal (with-output-to-string (s)
+                   (pprint-logical-block (s list
+                                            :per-line-prefix prefix
+                                            :suffix suffix)
+                     (format s "~{~W~^~:@_~}" list)))
+                 (format nil ";1~%~
+                              ;2~%~
+                              ;3x"))))
+
+;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
+;;; from , .FOO and , @FOO
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(,  .foo) :stream s :pretty t :readably t))
+	 "`(, .FOO)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '`(,  @foo) :stream s :pretty t :readably t))
+	 "`(, @FOO)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (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))"))
+;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
+;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
+;;; these assertions, like the ones above, are fragile.  Likewise, it
+;;; is very possible that at some point READABLY printing backquote
+;;; expressions will have to change to printing the low-level conses,
+;;; since the magical symbols are accessible though (car '`(,foo)) and
+;;; friends.  HATE HATE HATE.  -- CSR, 2004-06-10
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '``(foo ,@',@bar) :stream s :pretty t))
+	 "``(FOO ,@',@BAR)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '``(,,foo ,',foo foo) :stream s :pretty t))
+	 "``(,,FOO ,',FOO FOO)"))
+(assert (equal
+	 (with-output-to-string (s)
+	   (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
+	 "``(((,,FOO) ,',FOO) FOO)"))
+
+;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
+;;; rush to coerce them to functions.
+(set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
+(defun ppd-function-name (s o)
+  (print (length o) s))
+(let ((s (with-output-to-string (s)
+	   (pprint '(frob a b) s))))
+  (assert (position #\3 s)))
+
 ;;; success
 (quit :unix-status 104)