(prog1 nil
(setf (cdr *circ-list*) *circ-list*)))
+;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
+;;; the #1= and mark *CIRC-LIST* as having been printed for the first
+;;; time. After that any attempt to print *CIRC-LIST* must result in
+;;; in a #1# being printed. Thus the right output is (for once)
+;;; #1=#1#. -- JES, 2005-06-05
+#+nil
;;; circular lists are still being printed correctly?
(assert (equal
(with-output-to-string (*standard-output*)
(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)"))
+\f
+;;; 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)))
+\f
+;; Test that circularity detection works with pprint-logical-block
+;; (including when called through pprint-dispatch).
+(let ((*print-pretty* t)
+ (*print-circle* t)
+ (*print-pprint-dispatch* (copy-pprint-dispatch)))
+ (labels ((pprint-a (stream form &rest rest)
+ (declare (ignore rest))
+ (pprint-logical-block (stream form :prefix "<" :suffix ">")
+ (pprint-exit-if-list-exhausted)
+ (loop
+ (write (pprint-pop) :stream stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)))))
+ (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
+ (assert (string= "<A 1 2 3>"
+ (with-output-to-string (s)
+ (write '(a 1 2 3) :stream s))))
+ (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
+ (with-output-to-string (s)
+ (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
+ (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
+ (with-output-to-string (s)
+ (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s))))))
+
+;; Test that a circular improper list inside a logical block works.
+(let ((*print-circle* t)
+ (*print-pretty* t))
+ (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
+ (with-output-to-string (s)
+ (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s)))))
+\f
;;; success
(quit :unix-status 104)
projects / sbcl.git / blobdiff