Avoid forward references to PARSE-mumble-TYPE condition classes.
[sbcl.git] / tests / pprint.impure.lisp
blob3e63f991090d4a8ade4604498ce0addb1144fa14
1 ;;;; test of the pretty-printer
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
14 (in-package :cl-user)
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)))
21 (handler-bind ((warning #'muffle-warning)) ; nonexistent types
22 (set-pprint-dispatch 'foo1 #'pprint-fill 5 tbl)
23 (set-pprint-dispatch 'fool #'pprint-fill 0 tbl)
24 (set-pprint-dispatch 'foo2 #'pprint-fill 5 tbl))
25 (let ((entries (sb-pretty::pprint-dispatch-table-entries tbl)))
26 (assert (equal (mapcar #'sb-pretty::pprint-dispatch-entry-type entries)
27 '(foo1 foo2 fool))))))
29 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
30 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
31 ;;;; - didn't really work:
32 ;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
33 ;;;; (let ((*print-circle* t)) (describe (make-hash-table)))
34 ;;;; is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
35 ;;;; ..."
36 ;;;; So, this was mainly a pretty printing problem.
38 ;;; Create a circular list.
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (defparameter *circ-list* '(1 1))
41 (prog1 nil
42 (setf (cdr *circ-list*) *circ-list*)))
44 ;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
45 ;;; the #1= and mark *CIRC-LIST* as having been printed for the first
46 ;;; time. After that any attempt to print *CIRC-LIST* must result in
47 ;;; in a #1# being printed. Thus the right output is (for once)
48 ;;; #1=#1#. -- JES, 2005-06-05
49 #+nil
50 ;;; circular lists are still being printed correctly?
51 (assert (equal
52 (with-output-to-string (*standard-output*)
53 (let ((*print-circle* t))
54 (pprint-logical-block (*standard-output* *circ-list*)
55 (format *standard-output* "~S" *circ-list*))))
56 "#1=(1 . #1#)"))
58 ;;; test from CLHS
59 (with-test (:name :pprint-clhs-example)
60 (assert (equal
61 (with-output-to-string (*standard-output*)
62 (let ((a (list 1 2 3)))
63 (setf (cdddr a) a)
64 (let ((*print-circle* t))
65 (write a :stream *standard-output*))
66 :done))
67 "#1=(1 2 3 . #1#)")))
69 (with-test (:name (:pprint :bug-99))
70 (assert (equal
71 (with-output-to-string (*standard-output*)
72 (let* ((*print-circle* t))
73 (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
74 'eql 'eql)))
75 "EQL is EQL. This was not seen!"))
77 (assert (equal
78 (with-output-to-string (*standard-output*)
79 (let* ((*print-circle* t))
80 (format *standard-output*
81 "~@<~S ~_is ~S and ~S. This was not seen!~:>"
82 'eql 'eql 'eql)))
83 "EQL is EQL and EQL. This was not seen!")))
85 ;;; the original test for BUG 99 (only interactive), no obvious
86 ;;; way to make an automated test:
87 ;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
89 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
90 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
91 (with-test (:name :pprint-logical-block-arguments-complex-strings)
92 (let ((list '(1 2 3))
93 (prefix (make-array 2
94 :element-type 'character
95 :displaced-to ";x"
96 :fill-pointer 1))
97 (suffix (make-array 2
98 :element-type 'character
99 :displaced-to ">xy"
100 :displaced-index-offset 1
101 :fill-pointer 1)))
102 (assert (equal (with-output-to-string (s)
103 (pprint-logical-block (s list
104 :per-line-prefix prefix
105 :suffix suffix)
106 (format s "~{~W~^~:@_~}" list)))
107 (format nil ";1~%~
108 ;2~%~
109 ;3x")))))
111 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
112 ;;; from , .FOO and , @FOO
113 (with-test (:name :pprint-backquote-magic)
114 (assert (equal
115 (with-output-to-string (s)
116 (write '`(, .foo) :stream s :pretty t :readably t))
117 "`(, .FOO)"))
118 (assert (equal
119 (with-output-to-string (s)
120 (write '`(, @foo) :stream s :pretty t :readably t))
121 "`(, @FOO)"))
122 (assert (equal
123 (with-output-to-string (s)
124 (write '`(, ?foo) :stream s :pretty t :readably t))
125 "`(,?FOO)")))
127 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
128 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
129 (with-test (:name :pprint-leaking-backq-comma)
130 (assert (equal
131 (with-output-to-string (s)
132 (write '`(foo ,x) :stream s :pretty t :readably t))
133 "`(FOO ,X)"))
134 (assert (equal
135 (with-output-to-string (s)
136 (write '`(foo ,@x) :stream s :pretty t :readably t))
137 "`(FOO ,@X)"))
138 (assert (equal
139 (with-output-to-string (s)
140 (write '`(foo ,.x) :stream s :pretty t :readably t))
141 "`(FOO ,.X)"))
142 (assert (equal
143 (with-output-to-string (s)
144 (write '`(lambda ,x) :stream s :pretty t :readably t))
145 "`(LAMBDA ,X)"))
146 (assert (equal
147 (with-output-to-string (s)
148 (write '`(lambda ,@x) :stream s :pretty t :readably t))
149 "`(LAMBDA ,@X)"))
150 (assert (equal
151 (with-output-to-string (s)
152 (write '`(lambda ,.x) :stream s :pretty t :readably t))
153 "`(LAMBDA ,.X)"))
154 (assert (equal
155 (with-output-to-string (s)
156 (write '`(lambda (,x)) :stream s :pretty t :readably t))
157 "`(LAMBDA (,X))")))
159 (defun unwhitespaceify (string)
160 (let ((string (substitute #\Space #\Newline string)))
161 ;; highly inefficient. this is not how you'd do this in real life.
162 (loop (let ((p (search " " string)))
163 (when (not p) (return string))
164 (setq string
165 (concatenate 'string
166 (subseq string 0 p)
167 (subseq string (1+ p))))))))
169 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
170 ;;; and fixed a little more by DPK.
171 (with-test (:name :pprint-more-backquote-brokeness)
172 (flet ((try (input expect)
173 (assert (equalp (read-from-string expect) input))
174 (let ((actual (unwhitespaceify (write-to-string input :pretty t))))
175 (unless (equal actual expect)
176 (error "Failed test for ~S. Got ~S~%"
177 expect actual)))))
178 (try '``(foo ,@',@bar) "``(FOO ,@',@BAR)")
179 (try '``(,,foo ,',foo foo) "``(,,FOO ,',FOO FOO)")
180 (try '``(((,,foo) ,',foo) foo) "``(((,,FOO) ,',FOO) FOO)")
181 (try '`#() "`#()")
182 (try '`#(,bar) "`#(,BAR)")
183 (try '`#(,(bar)) "`#(,(BAR))")
184 (try '`#(,@bar) "`#(,@BAR)")
185 (try '`#(,@(bar)) "`#(,@(BAR))")
186 (try '`#(a ,b c) "`#(A ,B C)")
187 (try '`#(,@A ,b c) "`#(,@A ,B C)")
188 (try '`(,a . #(foo #() #(,bar) ,bar)) "`(,A . #(FOO #() #(,BAR) ,BAR))")
189 (try '(let ((foo (x))) `(let (,foo) (setq ,foo (y)) (baz ,foo)))
190 "(LET ((FOO (X))) `(LET (,FOO) (SETQ ,FOO (Y)) (BAZ ,FOO)))")
191 (try '(let `((,a ,b)) :forms) "(LET `((,A ,B)) :FORMS)")
192 (try '(lambda `(,x ,y) :forms) "(LAMBDA `(,X ,Y) :FORMS)")
193 (try '(defun f `(,x ,y) :forms) "(DEFUN F `(,X ,Y) :FORMS)")))
196 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
197 ;;; rush to coerce them to functions.
198 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
199 (defun ppd-function-name (s o)
200 (print (length o) s))
202 (with-test (:name (:set-pprint-dispatch :no-function-coerce)))
203 (let ((s (with-output-to-string (s)
204 (pprint '(frob a b) s))))
205 (assert (position #\3 s)))
207 ;; Test that circularity detection works with pprint-logical-block
208 ;; (including when called through pprint-dispatch).
209 (with-test (:name :pprint-circular-detection)
210 (let ((*print-pretty* t)
211 (*print-circle* t)
212 (*print-pprint-dispatch* (copy-pprint-dispatch)))
213 (labels ((pprint-a (stream form &rest rest)
214 (declare (ignore rest))
215 (pprint-logical-block (stream form :prefix "<" :suffix ">")
216 (pprint-exit-if-list-exhausted)
217 (loop
218 (write (pprint-pop) :stream stream)
219 (pprint-exit-if-list-exhausted)
220 (write-char #\space stream)))))
221 (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
222 (assert (string= "<A 1 2 3>"
223 (with-output-to-string (s)
224 (write '(a 1 2 3) :stream s))))
225 (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
226 (with-output-to-string (s)
227 (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
228 (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
229 (with-output-to-string (s)
230 (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))))
232 ;; Test that a circular improper list inside a logical block works.
233 (with-test (:name :pprint-circular-improper-lists-inside-logical-blocks)
234 (let ((*print-circle* t)
235 (*print-pretty* t))
236 (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
237 (with-output-to-string (s)
238 (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))))
240 ;;; Printing malformed defpackage forms without errors.
241 (with-test (:name :pprint-defpackage)
242 (let ((*standard-output* (make-broadcast-stream)))
243 (pprint '(defpackage :foo nil))
244 (pprint '(defpackage :foo 42))))
246 (with-test (:name :standard-pprint-dispatch-modified)
247 (assert
248 (eq :error
249 (handler-case (with-standard-io-syntax
250 (set-pprint-dispatch 'symbol (constantly nil))
251 :no-error)
252 (sb-int:standard-pprint-dispatch-table-modified-error ()
253 :error)))))
255 (with-test (:name :pprint-defmethod-lambda-list-function)
256 (flet ((to-string (form)
257 (let ((string (with-output-to-string (s) (pprint form s))))
258 (assert (eql #\newline (char string 0)))
259 (subseq string 1))))
260 (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
261 (to-string `(defmethod foo ((function cons)) function))))
262 (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
263 (to-string `(defmethod foo :after (function cons) function))))))
265 (defclass frob () ())
267 (defmethod print-object ((obj frob) stream)
268 (print-unreadable-object (obj stream :type nil :identity nil)
269 (format stream "FRABOTZICATOR")))
271 ;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
272 (with-test (:name (:pprint-unreadable-object :no-ugliness-when-type=nil))
273 (assert (equal "#<FRABOTZICATOR>"
274 (let ((*print-right-margin* 5)
275 (*print-pretty* t))
276 (format nil "~@<~S~:>" (make-instance 'frob))))))
278 (with-test (:name :pprint-logical-block-code-deletion-node)
279 (handler-case
280 (compile nil
281 `(lambda (words &key a b c)
282 (pprint-logical-block (nil words :per-line-prefix (or a b c))
283 (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))))
284 ((or sb-ext:compiler-note warning) (c)
285 (error c))))
287 (with-test (:name :pprint-logical-block-multiple-per-line-prefix-eval)
288 (funcall (compile nil
289 `(lambda ()
290 (let ((n 0))
291 (with-output-to-string (s)
292 (pprint-logical-block (s nil :per-line-prefix (if (eql 1 (incf n))
293 "; "
294 (error "oops")))
295 (pprint-newline :mandatory s)
296 (pprint-newline :mandatory s)))
297 n)))))
299 (with-test (:name :can-restore-orig-pprint-dispatch-table)
300 (let* ((orig (pprint-dispatch 'some-symbol))
301 (alt (lambda (&rest args) (apply orig args))))
302 (set-pprint-dispatch 'symbol alt)
303 (assert (eq alt (pprint-dispatch 'some-symbol)))
304 (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
305 (assert (eq orig (pprint-dispatch 'some-symbol)))
306 (assert (not (eq alt orig)))))
308 (with-test (:name :pprint-improper-list)
309 (let* ((max-length 10)
310 (stream (make-broadcast-stream))
311 (errors
312 (loop for symbol being the symbol in :cl
313 nconc
314 (loop for i from 1 below max-length
315 for list = (cons symbol 10) then (cons symbol list)
316 when (nth-value 1 (ignore-errors (pprint list stream)))
317 collect (format nil "(~{~a ~}~a . 10)" (butlast list) symbol)))))
318 (when errors
319 (error "Can't PPRINT improper lists: ~a" errors))))
321 (with-test (:name :pprint-circular-backq-comma)
322 ;; LP 1161218 reported by James M. Lawrence
323 (let ((string (write-to-string '(let ((#1=#:var '(99)))
324 `(progn ,@(identity #1#)))
325 :circle t :pretty t)))
326 (assert (not (search "#2#" string)))))
328 (with-test (:name :pprint-dotted-setf)
329 (let ((*print-pretty* t))
330 (equal (format nil "~a" '(setf . a))
331 "(SETF . A)")))
333 (with-test (:name :literal-fun-nested-lists)
334 (assert (search "EQUALP" (format nil "~:w" `((((((,#'equalp)))))))
335 :test #'char-equal)))
337 (defvar *a* (make-array 3 :fill-pointer 0))
338 (with-test (:name :pprint-logical-block-eval-order)
339 (flet ((vp (x) (vector-push x *a*)))
340 (pprint-logical-block (nil (progn (vp 1) '(foo))
341 :suffix (progn (vp 2) "}")
342 :prefix (progn (vp 3) "{"))
343 (write (pprint-pop))))
344 (assert (equalp *a* #(1 2 3))))
346 ;; these warn, but "work" in as much as they don't kill the machinery
347 (with-test (:name (:pprint-dispatch :set-ppd-unknown-type))
348 (handler-bind ((warning #'muffle-warning))
349 (assert-signal
350 (set-pprint-dispatch 'frood
351 (lambda (stream obj)
352 (let ((*print-pretty* nil))
353 (format stream "[frood: ~D]" obj))))
354 warning)
355 ;; We expect multiple warnings since the type specifier references
356 ;; multiple undefined things.
357 (assert-signal
358 (set-pprint-dispatch '(or weasel (and woodle (satisfies thing)))
359 (lambda (stream obj)
360 (format stream "hi ~A!" (type-of obj))))
361 warning 3)
362 (write-to-string (macroexpand '(setf (values a b) (floor x y)))
363 :pretty t)
364 ;; yay, we're not dead
367 (with-test (:name (:pprint-dispatch :unknown-type-1a))
368 (assert (string= (write-to-string (list 1 2 3 1006) :pretty t)
369 "(1 2 3 1006)")))
370 (deftype frood () '(integer 1005 1006))
371 (with-test (:name (:pprint-dispatch :unknown-type-1b))
372 (assert (string= (write-to-string (list 1 2 3 1006) :pretty t)
373 "(1 2 3 [frood: 1006])")))
374 (defstruct weasel)
375 (with-test (:name (:pprint-dispatch :unknown-type-2a))
376 ;; still can't use the dispatch entry because of the OR
377 ;; even though WEASEL "could have" eagerly returned T.
378 (assert (string= (write-to-string (make-weasel) :pretty t)
379 "#S(WEASEL)")))
380 (defstruct woodle)
381 (with-test (:name (:pprint-dispatch :unknown-type-2b))
382 ;; still no, because #'THING is not boundp
383 (assert (string= (write-to-string (make-weasel) :pretty t)
384 "#S(WEASEL)"))
385 (defun thing (x) x)
386 (assert (string= (write-to-string (make-weasel) :pretty t)
387 "hi WEASEL!")))
389 (deftype known-cons ()
390 '(cons (member known-cons other-known-cons other-other)))
391 (with-test (:name (:pprint-dispatch :known-cons-type))
392 (flet ((pprint-known-cons (stream obj)
393 (format stream "#<KNOWN-CONS ~S>" (cdr obj))))
394 (set-pprint-dispatch 'known-cons #'pprint-known-cons))
395 (let ((hashtable (sb-pretty::pprint-dispatch-table-cons-entries
396 *print-pprint-dispatch*)))
397 ;; First ensure that the CONS table was used
398 (assert (gethash 'known-cons hashtable))
399 ;; Check that dispatch entries are shared. In practice it is not "useful"
400 ;; but it is a consequence of the general approach of allowing any MEMBER
401 ;; type versus disallowing MEMBER types of more than one element.
402 (assert (eq (gethash 'known-cons hashtable)
403 (gethash 'other-known-cons hashtable)))
404 (assert (eq (gethash 'known-cons hashtable)
405 (gethash 'other-other hashtable))))
406 (assert (string= (write-to-string (cons 'known-cons t) :pretty t)
407 "#<KNOWN-CONS T>"))
408 (assert (string= (write-to-string (cons 'known-cons (cons 'known-cons t)) :pretty t)
409 "#<KNOWN-CONS #<KNOWN-CONS T>>")))
411 ;; force MACDADDY to be a closure over X.
412 (let ((x 3)) (defmacro macdaddy (a b &body z) a b z `(who-cares ,x)) (incf x))
414 (with-test (:name :closure-macro-arglist)
415 ;; assert correct test setup - MACDADDY is a closure
416 (assert (eq (sb-kernel:fun-subtype (macro-function 'macdaddy))
417 sb-vm:closure-header-widetag))
418 ;; MACRO-INDENTATION used %simple-fun-arglist instead of %fun-arglist.
419 ;; Depending on your luck it would either not return the right answer,
420 ;; or crash, depending on what lay at 4 words past the function address.
421 (assert (= (sb-pretty::macro-indentation 'macdaddy) 2)))
423 ;;; success