1 ;;;; test of the pretty-printer
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
17 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
18 ;;;; - didn't really work:
19 ;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
20 ;;;; (let ((*print-circle* t)) (describe (make-hash-table)))
21 ;;;; is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
23 ;;;; So, this was mainly a pretty printing problem.
25 ;;; Create a circular list.
26 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 (defparameter *circ-list
* '(1 1))
29 (setf (cdr *circ-list
*) *circ-list
*)))
31 ;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
32 ;;; the #1= and mark *CIRC-LIST* as having been printed for the first
33 ;;; time. After that any attempt to print *CIRC-LIST* must result in
34 ;;; in a #1# being printed. Thus the right output is (for once)
35 ;;; #1=#1#. -- JES, 2005-06-05
37 ;;; circular lists are still being printed correctly?
39 (with-output-to-string (*standard-output
*)
40 (let ((*print-circle
* t
))
41 (pprint-logical-block (*standard-output
* *circ-list
*)
42 (format *standard-output
* "~S" *circ-list
*))))
46 (with-test (:name
:pprint-clhs-example
)
48 (with-output-to-string (*standard-output
*)
49 (let ((a (list 1 2 3)))
51 (let ((*print-circle
* t
))
52 (write a
:stream
*standard-output
*))
56 (with-test (:name
(:pprint
:bug-99
))
58 (with-output-to-string (*standard-output
*)
59 (let* ((*print-circle
* t
))
60 (format *standard-output
* "~@<~S ~_is ~S. This was not seen!~:>"
62 "EQL is EQL. This was not seen!"))
65 (with-output-to-string (*standard-output
*)
66 (let* ((*print-circle
* t
))
67 (format *standard-output
*
68 "~@<~S ~_is ~S and ~S. This was not seen!~:>"
70 "EQL is EQL and EQL. This was not seen!")))
72 ;;; the original test for BUG 99 (only interactive), no obvious
73 ;;; way to make an automated test:
74 ;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
76 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
77 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
78 (with-test (:name
:pprint-logical-block-arguments-complex-strings
)
81 :element-type
'character
85 :element-type
'character
87 :displaced-index-offset
1
89 (assert (equal (with-output-to-string (s)
90 (pprint-logical-block (s list
91 :per-line-prefix prefix
93 (format s
"~{~W~^~:@_~}" list
)))
98 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
99 ;;; from , .FOO and , @FOO
100 (with-test (:name
:pprint-backquote-magic
)
102 (with-output-to-string (s)
103 (write '`(, .foo
) :stream s
:pretty t
:readably t
))
106 (with-output-to-string (s)
107 (write '`(, @foo
) :stream s
:pretty t
:readably t
))
110 (with-output-to-string (s)
111 (write '`(, ?foo
) :stream s
:pretty t
:readably t
))
114 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
115 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
116 (with-test (:name
:pprint-leaking-backq-comma
)
118 (with-output-to-string (s)
119 (write '`(foo ,x
) :stream s
:pretty t
:readably t
))
122 (with-output-to-string (s)
123 (write '`(foo ,@x
) :stream s
:pretty t
:readably t
))
125 #+nil
; '`(foo ,.x) => '`(foo ,@x) apparently.
127 (with-output-to-string (s)
128 (write '`(foo ,.x
) :stream s
:pretty t
:readably t
))
131 (with-output-to-string (s)
132 (write '`(lambda ,x
) :stream s
:pretty t
:readably t
))
135 (with-output-to-string (s)
136 (write '`(lambda ,@x
) :stream s
:pretty t
:readably t
))
140 (with-output-to-string (s)
141 (write '`(lambda ,.x
) :stream s
:pretty t
:readably t
))
144 (with-output-to-string (s)
145 (write '`(lambda (,x
)) :stream s
:pretty t
:readably t
))
148 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
149 ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
150 ;;; these assertions, like the ones above, are fragile. Likewise, it
151 ;;; is very possible that at some point READABLY printing backquote
152 ;;; expressions will have to change to printing the low-level conses,
153 ;;; since the magical symbols are accessible though (car '`(,foo)) and
154 ;;; friends. HATE HATE HATE. -- CSR, 2004-06-10
155 (with-test (:name
:pprint-more-backquote-brokeness
)
156 (flet ((try (input expect
)
157 (assert (equalp (read-from-string expect
) input
))
158 (let ((actual (write-to-string input
:pretty t
)))
159 (unless (equal actual expect
)
160 (error "Failed test for ~S. Got ~S~%"
162 (try '``(foo ,@',@bar
) "``(FOO ,@',@BAR)")
163 (try '``(,,foo
,',foo foo
) "``(,,FOO ,',FOO FOO)")
164 (try '``(((,,foo
) ,',foo
) foo
) "``(((,,FOO) ,',FOO) FOO)")
166 (try '`#(,bar
) "`#(,BAR)")
167 (try '`#(,(bar)) "`#(,(BAR))")
168 (try '`#(,@bar
) "`#(,@BAR)")
169 (try '`#(,@(bar)) "`#(,@(BAR))")
170 (try '`#(a ,b c
) "`#(A ,B C)")
171 (try '`#(,@A
,b c
) "`#(,@A ,B C)")
172 (try '`(,a .
#(foo #() #(,bar
) ,bar
)) "`(,A . #(FOO #() #(,BAR) ,BAR))")
173 (try '(let ((foo (x))) `(let (,foo
) (setq ,foo
(y)) (baz ,foo
)))
174 ;; PPRINT-LET emits a mandatory newline after the bindings,
175 ;; otherwise this'd fit on one line given an adequate right margin.
182 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
183 ;;; rush to coerce them to functions.
184 (set-pprint-dispatch '(cons (eql frob
)) 'ppd-function-name
)
185 (defun ppd-function-name (s o
)
186 (print (length o
) s
))
188 (with-test (:name
(:set-pprint-dispatch
:no-function-coerce
)))
189 (let ((s (with-output-to-string (s)
190 (pprint '(frob a b
) s
))))
191 (assert (position #\
3 s
)))
193 ;; Test that circularity detection works with pprint-logical-block
194 ;; (including when called through pprint-dispatch).
195 (with-test (:name
:pprint-circular-detection
)
196 (let ((*print-pretty
* t
)
198 (*print-pprint-dispatch
* (copy-pprint-dispatch)))
199 (labels ((pprint-a (stream form
&rest rest
)
200 (declare (ignore rest
))
201 (pprint-logical-block (stream form
:prefix
"<" :suffix
">")
202 (pprint-exit-if-list-exhausted)
204 (write (pprint-pop) :stream stream
)
205 (pprint-exit-if-list-exhausted)
206 (write-char #\space stream
)))))
207 (set-pprint-dispatch '(cons (eql a
)) #'pprint-a
)
208 (assert (string= "<A 1 2 3>"
209 (with-output-to-string (s)
210 (write '(a 1 2 3) :stream s
))))
211 (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
212 (with-output-to-string (s)
213 (write '#2=(a 1 #2# #5=#(2) #5#) :stream s
))))
214 (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
215 (with-output-to-string (s)
216 (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s
)))))))
218 ;; Test that a circular improper list inside a logical block works.
219 (with-test (:name
:pprint-circular-improper-lists-inside-logical-blocks
)
220 (let ((*print-circle
* t
)
222 (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
223 (with-output-to-string (s)
224 (write '#1=(#2=(#2# .
#3=(#1# .
#3#))) :stream s
))))))
226 ;;; Printing malformed defpackage forms without errors.
227 (with-test (:name
:pprint-defpackage
)
228 (let ((*standard-output
* (make-broadcast-stream)))
229 (pprint '(defpackage :foo nil
))
230 (pprint '(defpackage :foo
42))))
232 (with-test (:name
:standard-pprint-dispatch-modified
)
235 (handler-case (with-standard-io-syntax
236 (set-pprint-dispatch 'symbol
(constantly nil
))
238 (sb-int:standard-pprint-dispatch-table-modified-error
()
241 (with-test (:name
:pprint-defmethod-lambda-list-function
)
242 (flet ((to-string (form)
243 (let ((string (with-output-to-string (s) (pprint form s
))))
244 (assert (eql #\newline
(char string
0)))
246 (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
247 (to-string `(defmethod foo ((function cons
)) function
))))
248 (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
249 (to-string `(defmethod foo :after
(function cons
) function
))))))
251 (defclass frob
() ())
253 (defmethod print-object ((obj frob
) stream
)
254 (print-unreadable-object (obj stream
:type nil
:identity nil
)
255 (format stream
"FRABOTZICATOR")))
257 ;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
258 (with-test (:name
(:pprint-unreadable-object
:no-ugliness-when-type
=nil
))
259 (assert (equal "#<FRABOTZICATOR>"
260 (let ((*print-right-margin
* 5)
262 (format nil
"~@<~S~:>" (make-instance 'frob
))))))
264 (with-test (:name
:pprint-logical-block-code-deletion-node
)
267 `(lambda (words &key a b c
)
268 (pprint-logical-block (nil words
:per-line-prefix
(or a b c
))
269 (pprint-fill *standard-output
* (sort (copy-seq words
) #'string
<) nil
))))
270 ((or sb-ext
:compiler-note warning
) (c)
273 (with-test (:name
:pprint-logical-block-multiple-per-line-prefix-eval
)
274 (funcall (compile nil
277 (with-output-to-string (s)
278 (pprint-logical-block (s nil
:per-line-prefix
(if (eql 1 (incf n
))
281 (pprint-newline :mandatory s
)
282 (pprint-newline :mandatory s
)))
285 (with-test (:name
:can-restore-orig-pprint-dispatch-table
)
286 (let* ((orig (pprint-dispatch 'some-symbol
))
287 (alt (lambda (&rest args
) (apply orig args
))))
288 (set-pprint-dispatch 'symbol alt
)
289 (assert (eq alt
(pprint-dispatch 'some-symbol
)))
290 (setf *print-pprint-dispatch
* (copy-pprint-dispatch nil
))
291 (assert (eq orig
(pprint-dispatch 'some-symbol
)))
292 (assert (not (eq alt orig
)))))
294 (with-test (:name
:pprint-improper-list
)
295 (let* ((max-length 10)
296 (stream (make-broadcast-stream))
298 (loop for symbol being the symbol in
:cl
300 (loop for i from
1 below max-length
301 for list
= (cons symbol
10) then
(cons symbol list
)
302 when
(nth-value 1 (ignore-errors (pprint list stream
)))
303 collect
(format nil
"(~{~a ~}~a . 10)" (butlast list
) symbol
)))))
305 (error "Can't PPRINT improper lists: ~a" errors
))))
307 (with-test (:name
:pprint-circular-backq-comma
)
308 ;; LP 1161218 reported by James M. Lawrence
309 (let ((string (write-to-string '(let ((#1=#:var
'(99)))
310 `(progn ,@(identity #1#)))
311 :circle t
:pretty t
)))
312 (assert (not (search "#2#" string
)))))
314 (with-test (:name
:pprint-dotted-setf
)
315 (let ((*print-pretty
* t
))
316 (equal (format nil
"~a" '(setf . a
))
319 (with-test (:name
:literal-fun-nested-lists
)
320 (assert (search "EQUALP" (format nil
"~:w" `((((((,#'equalp
)))))))
321 :test
#'char-equal
)))