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 ;;; circular lists are still being printed correctly?
33 (with-output-to-string (*standard-output
*)
34 (let ((*print-circle
* t
))
35 (pprint-logical-block (*standard-output
* *circ-list
*)
36 (format *standard-output
* "~S" *circ-list
*))))
41 (with-output-to-string (*standard-output
*)
42 (let ((a (list 1 2 3)))
44 (let ((*print-circle
* t
))
45 (write a
:stream
*standard-output
*))
49 ;;; test case 1 for bug 99
51 (with-output-to-string (*standard-output
*)
52 (let* ((*print-circle
* t
))
53 (format *standard-output
* "~@<~S ~_is ~S. This was not seen!~:>"
55 "EQL is EQL. This was not seen!"))
57 ;;; test case 2 for bug 99
59 (with-output-to-string (*standard-output
*)
60 (let* ((*print-circle
* t
))
61 (format *standard-output
*
62 "~@<~S ~_is ~S and ~S. This was not seen!~:>"
64 "EQL is EQL and EQL. This was not seen!"))
66 ;;; the original test for BUG 99 (only interactive), no obvious
67 ;;; way to make an automated test:
68 ;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
70 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
71 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
74 :element-type
'character
78 :element-type
'character
80 :displaced-index-offset
1
82 (assert (equal (with-output-to-string (s)
83 (pprint-logical-block (s list
84 :per-line-prefix prefix
86 (format s
"~{~W~^~:@_~}" list
)))
91 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
92 ;;; from , .FOO and , @FOO
94 (with-output-to-string (s)
95 (write '`(, .foo
) :stream s
:pretty t
:readably t
))
98 (with-output-to-string (s)
99 (write '`(, @foo
) :stream s
:pretty t
:readably t
))
102 (with-output-to-string (s)
103 (write '`(, ?foo
) :stream s
:pretty t
:readably t
))
106 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
107 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
109 (with-output-to-string (s)
110 (write '`(foo ,x
) :stream s
:pretty t
:readably t
))
113 (with-output-to-string (s)
114 (write '`(foo ,@x
) :stream s
:pretty t
:readably t
))
116 #+nil
; '`(foo ,.x) => '`(foo ,@x) apparently.
118 (with-output-to-string (s)
119 (write '`(foo ,.x
) :stream s
:pretty t
:readably t
))
122 (with-output-to-string (s)
123 (write '`(lambda ,x
) :stream s
:pretty t
:readably t
))
126 (with-output-to-string (s)
127 (write '`(lambda ,@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
))
138 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
139 ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
140 ;;; these assertions, like the ones above, are fragile. Likewise, it
141 ;;; is very possible that at some point READABLY printing backquote
142 ;;; expressions will have to change to printing the low-level conses,
143 ;;; since the magical symbols are accessible though (car '`(,foo)) and
144 ;;; friends. HATE HATE HATE. -- CSR, 2004-06-10
146 (with-output-to-string (s)
147 (write '``(foo ,@',@bar
) :stream s
:pretty t
))
150 (with-output-to-string (s)
151 (write '``(,,foo
,',foo foo
) :stream s
:pretty t
))
152 "``(,,FOO ,',FOO FOO)"))
154 (with-output-to-string (s)
155 (write '``(((,,foo
) ,',foo
) foo
) :stream s
:pretty t
))
156 "``(((,,FOO) ,',FOO) FOO)"))
158 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
159 ;;; rush to coerce them to functions.
160 (set-pprint-dispatch '(cons (eql frob
)) 'ppd-function-name
)
161 (defun ppd-function-name (s o
)
162 (print (length o
) s
))
163 (let ((s (with-output-to-string (s)
164 (pprint '(frob a b
) s
))))
165 (assert (position #\
3 s
)))
168 (quit :unix-status
104)