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 ;;;; Assert that entries inserted into a dispatch table with equal priority
17 ;;;; are order-preserving - unless they are of the form (CONS (EQL x)).
18 ;;;; This is not a requirement in general, but is quite reasonable.
19 (with-test (:name
:pprint-dispatch-order-preserving
)
20 (let ((tbl (sb-pretty::make-pprint-dispatch-table
#() nil nil
)))
21 (handler-bind ((warning #'muffle-warning
)) ; nonexistent types
22 ;; use EVAL because there are *two* warnings to muffle: first time
23 ;; is when the compiler sees a symbol used as an unknown type-specifier,
24 ;; then again when SET-PPRINT-DISPATCH can't associate to a known type.
25 ;; The latter is handled by the HANDLER-BIND, but the former is issued
26 ;; by the compiler when it digests these forms. I do not know why
27 ;; (DECLARE (MUFFLE-CONDITIONS STYLE-WARNING) doesn't work for that.
28 (set-pprint-dispatch (eval ''foo1
) #'pprint-fill
5 tbl
)
29 (set-pprint-dispatch (eval ''fool
) #'pprint-fill
0 tbl
)
30 (set-pprint-dispatch (eval ''foo2
) #'pprint-fill
5 tbl
))
31 (let ((entries (sb-pretty::pp-dispatch-entries tbl
)))
32 (assert (equal (map 'list
#'sb-pretty
::pprint-dispatch-entry-type entries
)
33 '(foo1 foo2 fool
))))))
35 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
36 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
37 ;;;; - didn't really work:
38 ;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
39 ;;;; (let ((*print-circle* t)) (describe (make-hash-table)))
40 ;;;; is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
42 ;;;; So, this was mainly a pretty printing problem.
44 ;;; Create a circular list.
45 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
46 (defparameter *circ-list
* '(1 1))
48 (setf (cdr *circ-list
*) *circ-list
*)))
50 ;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
51 ;;; the #1= and mark *CIRC-LIST* as having been printed for the first
52 ;;; time. After that any attempt to print *CIRC-LIST* must result in
53 ;;; in a #1# being printed. Thus the right output is (for once)
54 ;;; #1=#1#. -- JES, 2005-06-05
56 ;;; circular lists are still being printed correctly?
58 (with-output-to-string (*standard-output
*)
59 (let ((*print-circle
* t
))
60 (pprint-logical-block (*standard-output
* *circ-list
*)
61 (format *standard-output
* "~S" *circ-list
*))))
65 (with-test (:name
:pprint-clhs-example
)
67 (with-output-to-string (*standard-output
*)
68 (let ((a (list 1 2 3)))
70 (let ((*print-circle
* t
))
71 (write a
:stream
*standard-output
*))
75 (with-test (:name
(:pprint
:bug-99
))
77 (with-output-to-string (*standard-output
*)
78 (let* ((*print-circle
* t
))
79 (format *standard-output
* "~@<~S ~_is ~S. This was not seen!~:>"
81 "EQL is EQL. This was not seen!"))
84 (with-output-to-string (*standard-output
*)
85 (let* ((*print-circle
* t
))
86 (format *standard-output
*
87 "~@<~S ~_is ~S and ~S. This was not seen!~:>"
89 "EQL is EQL and EQL. This was not seen!")))
91 ;;; the original test for BUG 99 (only interactive), no obvious
92 ;;; way to make an automated test:
93 ;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
95 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
96 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
97 (with-test (:name
:pprint-logical-block-arguments-complex-strings
)
100 :element-type
'character
103 (suffix (make-array 2
104 :element-type
'character
106 :displaced-index-offset
1
108 (assert (equal (with-output-to-string (s)
109 (pprint-logical-block (s list
110 :per-line-prefix prefix
112 (format s
"~{~W~^~:@_~}" list
)))
117 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
118 ;;; from , .FOO and , @FOO
119 (with-test (:name
:pprint-backquote-magic
)
121 (with-output-to-string (s)
122 (write '`(, .foo
) :stream s
:pretty t
:readably t
))
125 (with-output-to-string (s)
126 (write '`(, @foo
) :stream s
:pretty t
:readably t
))
129 (with-output-to-string (s)
130 (write '`(, ?foo
) :stream s
:pretty t
:readably t
))
133 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
134 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
135 (with-test (:name
:pprint-leaking-backq-comma
)
137 (with-output-to-string (s)
138 (write '`(foo ,x
) :stream s
:pretty t
:readably t
))
141 (with-output-to-string (s)
142 (write '`(foo ,@x
) :stream s
:pretty t
:readably t
))
145 (with-output-to-string (s)
146 (write '`(foo ,.x
) :stream s
:pretty t
:readably t
))
149 (with-output-to-string (s)
150 (write '`(lambda ,x
) :stream s
:pretty t
:readably t
))
153 (with-output-to-string (s)
154 (write '`(lambda ,@x
) :stream s
:pretty t
:readably t
))
157 (with-output-to-string (s)
158 (write '`(lambda ,.x
) :stream s
:pretty t
:readably t
))
161 (with-output-to-string (s)
162 (write '`(lambda (,x
)) :stream s
:pretty t
:readably t
))
165 (defun unwhitespaceify (string)
166 (let ((string (substitute #\Space
#\Newline string
)))
167 ;; highly inefficient. this is not how you'd do this in real life.
168 (loop (let ((p (search " " string
)))
169 (when (not p
) (return string
))
173 (subseq string
(1+ p
))))))))
175 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
176 ;;; and fixed a little more by DPK.
177 (with-test (:name
:pprint-more-backquote-brokeness
)
178 (flet ((try (input expect
)
179 (assert (equalp (read-from-string expect
) input
))
180 (let ((actual (unwhitespaceify (write-to-string input
:pretty t
))))
181 (unless (equal actual expect
)
182 (error "Failed test for ~S. Got ~S~%"
184 (try '``(foo ,@',@bar
) "``(FOO ,@',@BAR)")
185 (try '``(,,foo
,',foo foo
) "``(,,FOO ,',FOO FOO)")
186 (try '``(((,,foo
) ,',foo
) foo
) "``(((,,FOO) ,',FOO) FOO)")
188 (try '`#(,bar
) "`#(,BAR)")
189 (try '`#(,(bar)) "`#(,(BAR))")
190 (try '`#(,@bar
) "`#(,@BAR)")
191 (try '`#(,@(bar)) "`#(,@(BAR))")
192 (try '`#(a ,b c
) "`#(A ,B C)")
193 (try '`#(,@A
,b c
) "`#(,@A ,B C)")
194 (try '`(,a .
#(foo #() #(,bar
) ,bar
)) "`(,A . #(FOO #() #(,BAR) ,BAR))")
195 (try '(let ((foo (x))) `(let (,foo
) (setq ,foo
(y)) (baz ,foo
)))
196 "(LET ((FOO (X))) `(LET (,FOO) (SETQ ,FOO (Y)) (BAZ ,FOO)))")
197 (try '(let `((,a
,b
)) :forms
) "(LET `((,A ,B)) :FORMS)")
198 (try '(lambda `(,x
,y
) :forms
) "(LAMBDA `(,X ,Y) :FORMS)")
199 (try '(defun f `(,x
,y
) :forms
) "(DEFUN F `(,X ,Y) :FORMS)")))
202 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
203 ;;; rush to coerce them to functions.
204 (set-pprint-dispatch '(cons (eql frob
)) 'ppd-function-name
)
205 (defun ppd-function-name (s o
)
206 (print (length o
) s
))
208 (with-test (:name
(:set-pprint-dispatch
:no-function-coerce
)))
209 (let ((s (with-output-to-string (s)
210 (pprint '(frob a b
) s
))))
211 (assert (position #\
3 s
)))
213 ;; Test that circularity detection works with pprint-logical-block
214 ;; (including when called through pprint-dispatch).
215 (with-test (:name
:pprint-circular-detection
)
216 (let ((*print-pretty
* t
)
218 (*print-pprint-dispatch
* (copy-pprint-dispatch)))
219 (labels ((pprint-a (stream form
&rest rest
)
220 (declare (ignore rest
))
221 (pprint-logical-block (stream form
:prefix
"<" :suffix
">")
222 (pprint-exit-if-list-exhausted)
224 (write (pprint-pop) :stream stream
)
225 (pprint-exit-if-list-exhausted)
226 (write-char #\space stream
)))))
227 (set-pprint-dispatch '(cons (eql a
)) #'pprint-a
)
228 (assert (string= "<A 1 2 3>"
229 (with-output-to-string (s)
230 (write '(a 1 2 3) :stream s
))))
231 (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
232 (with-output-to-string (s)
233 (write '#2=(a 1 #2# #5=#(2) #5#) :stream s
))))
234 (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
235 (with-output-to-string (s)
236 (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s
)))))))
238 ;; Test that a circular improper list inside a logical block works.
239 (with-test (:name
:pprint-circular-improper-lists-inside-logical-blocks
)
240 (let ((*print-circle
* t
)
242 (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
243 (with-output-to-string (s)
244 (write '#1=(#2=(#2# .
#3=(#1# .
#3#))) :stream s
))))))
246 ;;; Printing malformed defpackage forms without errors.
247 (with-test (:name
:pprint-defpackage
)
248 (let ((*standard-output
* (make-broadcast-stream)))
249 (pprint '(defpackage :foo nil
))
250 (pprint '(defpackage :foo
42))))
252 (with-test (:name
:standard-pprint-dispatch-modified
)
255 (handler-case (with-standard-io-syntax
256 (set-pprint-dispatch 'symbol
(constantly nil
))
258 (sb-int:standard-pprint-dispatch-table-modified-error
()
261 (defun pprint-to-string (form)
262 (let ((string (with-output-to-string (s) (pprint form s
))))
263 (assert (eql #\newline
(char string
0)))
265 (with-test (:name
:pprint-defmethod-lambda-list-function
)
266 (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
267 (pprint-to-string `(defmethod foo ((function cons
)) function
))))
268 (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
269 (pprint-to-string `(defmethod foo :after
(function cons
) function
))))
270 (assert (equal "(DEFMETHOD FOO :BEFORE ((FUNCTION (EQL #'FOO))) FUNCTION)"
271 (pprint-to-string `(DEFMETHOD FOO
:BEFORE
((FUNCTION (EQL #'FOO
))) FUNCTION
)))))
273 (with-test (:name
:pprint-lambda-list-quote
)
274 (assert (equal "(LAMBDA (&KEY (BAR 'BAZ)))"
275 (pprint-to-string '(lambda (&key
(bar 'baz
)))))))
277 (defclass frob
() ())
279 (defmethod print-object ((obj frob
) stream
)
280 (print-unreadable-object (obj stream
:type nil
:identity nil
)
281 (format stream
"FRABOTZICATOR")))
283 ;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
284 (with-test (:name
(:pprint-unreadable-object
:no-ugliness-when-type
=nil
))
285 (assert (equal "#<FRABOTZICATOR>"
286 (let ((*print-right-margin
* 5)
288 (format nil
"~@<~S~:>" (make-instance 'frob
))))))
290 (with-test (:name
:pprint-logical-block-code-deletion-node
)
293 `(lambda (words &key a b c
)
294 (pprint-logical-block (nil words
:per-line-prefix
(or a b c
))
295 (pprint-fill *standard-output
* (sort (copy-seq words
) #'string
<) nil
))))
296 ((or sb-ext
:compiler-note warning
) (c)
299 (with-test (:name
:pprint-logical-block-multiple-per-line-prefix-eval
)
300 (funcall (compile nil
302 (declare (muffle-conditions compiler-note
))
304 (with-output-to-string (s)
305 (pprint-logical-block (s nil
:per-line-prefix
(if (eql 1 (incf n
))
308 (pprint-newline :mandatory s
)
309 (pprint-newline :mandatory s
)))
312 (with-test (:name
:can-restore-orig-pprint-dispatch-table
)
313 (let* ((orig (pprint-dispatch 'some-symbol
))
314 (alt (lambda (&rest args
) (apply orig args
))))
315 (set-pprint-dispatch 'symbol alt
)
316 (assert (eq alt
(pprint-dispatch 'some-symbol
)))
317 (setf *print-pprint-dispatch
* (copy-pprint-dispatch nil
))
318 (assert (eq orig
(pprint-dispatch 'some-symbol
)))
319 (assert (not (eq alt orig
)))))
321 (with-test (:name
:pprint-improper-list
)
322 (let* ((max-length 10)
323 (stream (make-broadcast-stream))
325 (loop for symbol being the symbol in
:cl
327 (loop for i from
1 below max-length
328 for list
= (cons symbol
10) then
(cons symbol list
)
329 when
(nth-value 1 (ignore-errors (pprint list stream
)))
330 collect
(format nil
"(~{~a ~}~a . 10)" (butlast list
) symbol
)))))
332 (error "Can't PPRINT improper lists: ~a" errors
))))
334 (with-test (:name
:pprint-circular-backq-comma
)
335 ;; LP 1161218 reported by James M. Lawrence
336 (let ((string (write-to-string '(let ((#1=#:var
'(99)))
337 `(progn ,@(identity #1#)))
338 :circle t
:pretty t
)))
339 (assert (not (search "#2#" string
)))))
341 (with-test (:name
:pprint-dotted-setf
)
342 (let ((*print-pretty
* t
))
343 (equal (format nil
"~a" '(setf . a
))
346 (with-test (:name
:literal-fun-nested-lists
)
347 (assert (search "EQUALP" (format nil
"~:w" `((((((,#'equalp
)))))))
348 :test
#'char-equal
)))
350 (defvar *a
* (make-array 3 :fill-pointer
0))
351 (with-test (:name
:pprint-logical-block-eval-order
)
352 (let ((s (make-broadcast-stream)))
353 (flet ((vp (x) (vector-push x
*a
*)))
354 (pprint-logical-block (s (progn (vp 1) '(foo))
355 :suffix
(progn (vp 2) "}")
356 :prefix
(progn (vp 3) "{"))
357 (write (pprint-pop) :stream s
))))
358 (assert (equalp *a
* #(1 2 3))))
360 ;; these warn, but "work" in as much as they don't kill the machinery
361 (with-test (:name
(:pprint-dispatch
:set-ppd-unknown-type
))
362 (handler-bind ((warning #'muffle-warning
))
364 (set-pprint-dispatch 'frood
366 (let ((*print-pretty
* nil
))
367 (format stream
"[frood: ~D]" obj
))))
369 ;; We expect multiple warnings since the type specifier references
370 ;; multiple undefined things.
372 (set-pprint-dispatch '(or weasel
(and woodle
(satisfies thing
)))
374 (format stream
"hi ~A!" (type-of obj
))))
376 (write-to-string (macroexpand '(setf (values a b
) (floor x y
)))
378 ;; yay, we're not dead
381 (with-test (:name
(:pprint-dispatch
:unknown-type-1a
))
382 (assert (string= (write-to-string (list 1 2 3 1006) :pretty t
)
384 (deftype frood
() '(integer 1005 1006))
385 (with-test (:name
(:pprint-dispatch
:unknown-type-1b
))
386 (assert (string= (write-to-string (list 1 2 3 1006) :pretty t
)
387 "(1 2 3 [frood: 1006])")))
389 (with-test (:name
(:pprint-dispatch
:unknown-type-2a
))
390 ;; still can't use the dispatch entry because of the OR
391 ;; even though WEASEL "could have" eagerly returned T.
392 (assert (string= (write-to-string (make-weasel) :pretty t
)
395 (with-test (:name
(:pprint-dispatch
:unknown-type-2b
))
396 ;; still no, because #'THING is not boundp
397 (assert (string= (write-to-string (make-weasel) :pretty t
)
400 (assert (string= (write-to-string (make-weasel) :pretty t
)
403 (deftype known-cons
()
404 '(cons (member known-cons other-known-cons other-other
)))
405 (with-test (:name
(:pprint-dispatch
:known-cons-type
))
406 (flet ((pprint-known-cons (stream obj
)
407 (format stream
"#<KNOWN-CONS ~S>" (cdr obj
))))
408 (set-pprint-dispatch 'known-cons
#'pprint-known-cons
))
409 (let ((hashtable (sb-pretty::pp-dispatch-cons-entries
*print-pprint-dispatch
*)))
410 ;; First ensure that the CONS table was used
411 (assert (gethash 'known-cons hashtable
))
412 ;; Check that dispatch entries are shared. In practice it is not "useful"
413 ;; but it is a consequence of the general approach of allowing any MEMBER
414 ;; type versus disallowing MEMBER types of more than one element.
415 (assert (eq (gethash 'known-cons hashtable
)
416 (gethash 'other-known-cons hashtable
)))
417 (assert (eq (gethash 'known-cons hashtable
)
418 (gethash 'other-other hashtable
))))
419 (assert (string= (write-to-string (cons 'known-cons t
) :pretty t
)
421 (assert (string= (write-to-string (cons 'known-cons
(cons 'known-cons t
)) :pretty t
)
422 "#<KNOWN-CONS #<KNOWN-CONS T>>")))
424 ;; force MACDADDY to be a closure over X.
425 (let ((x 3)) (defmacro macdaddy
(a b
&body z
) a b z
`(who-cares ,x
)) (incf x
))
427 (defun indentation-of (name)
428 (sb-pretty::macro-indentation
(macro-function name
)))
430 (with-test (:name
:closure-macro-arglist
)
431 ;; assert correct test setup - MACDADDY is a closure if compiling,
432 ;; or a funcallable-instance if not
433 (assert (eq (sb-kernel:%fun-pointer-widetag
(macro-function 'macdaddy
))
434 #-interpreter sb-vm
:closure-widetag
435 #+interpreter sb-vm
:funcallable-instance-widetag
))
436 ;; MACRO-INDENTATION used %simple-fun-arglist instead of %fun-arglist.
437 ;; Depending on your luck it would either not return the right answer,
438 ;; or crash, depending on what lay at 4 words past the function address.
439 (assert (= (indentation-of 'macdaddy
) 2)))
441 (defmacro try1
(a b
&body fool
) `(baz ,a
,b
,fool
))
442 (defmacro try2
(a b
&optional
&body fool
) `(baz ,a
,b
,fool
))
443 (defmacro try3
(a b
&optional c
&body fool
) `(baz ,a
,b
,c
,fool
))
444 (defmacro try4
(a b . fool
) `(baz ,a
,b
,fool
))
445 (defmacro try5
(a b
&optional . fool
) `(baz ,a
,b
,fool
))
446 (defmacro try6
(a b
&optional c . fool
) `(baz ,a
,b
,c
,fool
))
447 (with-test (:name
:macro-indentation
)
448 (assert (= (indentation-of 'try1
) 2))
449 (assert (= (indentation-of 'try2
) 2))
450 (assert (= (indentation-of 'try3
) 3))
451 (assert (= (indentation-of 'try4
) 2))
452 (assert (= (indentation-of 'try5
) 2))
453 (assert (= (indentation-of 'try6
) 3)))
455 (defclass ship
() ())
456 (let ((ppd (copy-pprint-dispatch)))
457 (set-pprint-dispatch 'integer
459 (let ((*print-pretty
* nil
))
460 (format stream
"[[~d]]" obj
)))
463 (let ((string (write-to-string (make-instance 'ship
)
466 ;; Do not want to see "#<SHIP {[[decimal-integer]]}>"
467 (assert (not (search "{[[" string
)))))