0.8.12.15:
[sbcl.git] / tests / pprint.impure.lisp
1 ;;;; test of the pretty-printer
2
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.
13
14 (in-package :cl-user)
15
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)
22 ;;;; ..."
23 ;;;; So, this was mainly a pretty printing problem.
24
25 ;;; Create a circular list.
26 (eval-when (:compile-toplevel :load-toplevel :execute)
27   (defparameter *circ-list* '(1 1))
28   (prog1 nil
29     (setf (cdr *circ-list*) *circ-list*)))
30
31 ;;; circular lists are still being printed correctly?
32 (assert (equal
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*))))
37          "#1=(1 . #1#)"))
38
39 ;;; test from CLHS
40 (assert (equal
41          (with-output-to-string (*standard-output*)
42           (let ((a (list 1 2 3)))
43             (setf (cdddr a) a)
44             (let ((*print-circle* t))
45               (write a :stream *standard-output*))
46             :done))
47          "#1=(1 2 3 . #1#)"))
48
49 ;;; test case 1 for bug 99
50 (assert (equal
51          (with-output-to-string (*standard-output*)
52            (let* ((*print-circle* t))
53              (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
54                      'eql 'eql)))
55          "EQL is EQL. This was not seen!"))
56
57 ;;; test case 2 for bug 99
58 (assert (equal
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!~:>"
63                      'eql 'eql 'eql)))
64          "EQL is EQL and EQL. This was not seen!"))
65
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)))
69
70 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
71 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
72 (let ((list '(1 2 3))
73       (prefix (make-array 2
74                           :element-type 'character
75                           :displaced-to ";x"
76                           :fill-pointer 1))
77       (suffix (make-array 2
78                           :element-type 'character
79                           :displaced-to ">xy"
80                           :displaced-index-offset 1
81                           :fill-pointer 1)))
82   (assert (equal (with-output-to-string (s)
83                    (pprint-logical-block (s list
84                                             :per-line-prefix prefix
85                                             :suffix suffix)
86                      (format s "~{~W~^~:@_~}" list)))
87                  (format nil ";1~%~
88                               ;2~%~
89                               ;3x"))))
90
91 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
92 ;;; from , .FOO and , @FOO
93 (assert (equal
94          (with-output-to-string (s)
95            (write '`(,  .foo) :stream s :pretty t :readably t))
96          "`(, .FOO)"))
97 (assert (equal
98          (with-output-to-string (s)
99            (write '`(,  @foo) :stream s :pretty t :readably t))
100          "`(, @FOO)"))
101 (assert (equal
102          (with-output-to-string (s)
103            (write '`(,  ?foo) :stream s :pretty t :readably t))
104          "`(,?FOO)"))
105
106 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
107 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
108 (assert (equal
109          (with-output-to-string (s)
110            (write '`(foo ,x) :stream s :pretty t :readably t))
111          "`(FOO ,X)"))
112 (assert (equal
113          (with-output-to-string (s)
114            (write '`(foo ,@x) :stream s :pretty t :readably t))
115          "`(FOO ,@X)"))
116 #+nil ; '`(foo ,.x) => '`(foo ,@x) apparently. 
117 (assert (equal
118          (with-output-to-string (s)
119            (write '`(foo ,.x) :stream s :pretty t :readably t))
120          "`(FOO ,.X)"))
121 (assert (equal
122          (with-output-to-string (s)
123            (write '`(lambda ,x) :stream s :pretty t :readably t))
124          "`(LAMBDA ,X)"))
125 (assert (equal
126          (with-output-to-string (s)
127            (write '`(lambda ,@x) :stream s :pretty t :readably t))
128          "`(LAMBDA ,@X)"))
129 #+nil ; see above
130 (assert (equal
131          (with-output-to-string (s)
132            (write '`(lambda ,.x) :stream s :pretty t :readably t))
133          "`(LAMBDA ,.X)"))
134 (assert (equal
135          (with-output-to-string (s)
136            (write '`(lambda (,x)) :stream s :pretty t :readably t))
137          "`(LAMBDA (,X))"))
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
145 (assert (equal
146          (with-output-to-string (s)
147            (write '``(foo ,@',@bar) :stream s :pretty t))
148          "``(FOO ,@',@BAR)"))
149 (assert (equal
150          (with-output-to-string (s)
151            (write '``(,,foo ,',foo foo) :stream s :pretty t))
152          "``(,,FOO ,',FOO FOO)"))
153 (assert (equal
154          (with-output-to-string (s)
155            (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
156          "``(((,,FOO) ,',FOO) FOO)"))
157 \f
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)))
166 \f
167 ;;; success
168 (quit :unix-status 104)