1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Sat Jun 12 13:14:53 2004 |
---|
4 | ;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (deftest pprint-dispatch.1 |
---|
9 | (loop for x in (append *universe* *cl-symbols*) |
---|
10 | for vals = (multiple-value-list (pprint-dispatch x)) |
---|
11 | for vals2 = (multiple-value-list (pprint-dispatch |
---|
12 | x |
---|
13 | *print-pprint-dispatch*)) |
---|
14 | unless |
---|
15 | (and (= (length vals) 2) |
---|
16 | (= (length vals2) 2) |
---|
17 | (destructuring-bind (fun foundp) |
---|
18 | vals |
---|
19 | (if foundp |
---|
20 | (and (or (typep fun 'function) |
---|
21 | (and (symbolp fun) |
---|
22 | (symbol-function fun))) |
---|
23 | (destructuring-bind (fun2 foundp2) |
---|
24 | vals2 |
---|
25 | (and (equal fun fun2) |
---|
26 | foundp2))) |
---|
27 | (not (cadr vals2))))) |
---|
28 | collect (list x vals vals2)) |
---|
29 | nil) |
---|
30 | #| |
---|
31 | (deftest pprint-dispatch.2 |
---|
32 | (loop for sym in *cl-symbols* |
---|
33 | for x = (list sym nil nil) |
---|
34 | for vals = (multiple-value-list (pprint-dispatch x)) |
---|
35 | for vals2 = (multiple-value-list (pprint-dispatch |
---|
36 | x |
---|
37 | *print-pprint-dispatch*)) |
---|
38 | unless |
---|
39 | (and (= (length vals) 2) |
---|
40 | (= (length vals2) 2) |
---|
41 | (destructuring-bind (fun foundp) |
---|
42 | vals |
---|
43 | (if foundp |
---|
44 | (and (or (typep fun 'function) |
---|
45 | (and (symbolp fun) |
---|
46 | (symbol-function fun))) |
---|
47 | (destructuring-bind (fun2 foundp2) |
---|
48 | vals2 |
---|
49 | (and (equal fun fun2) |
---|
50 | foundp2))) |
---|
51 | (not (cadr vals2))))) |
---|
52 | collect (list x vals vals2)) |
---|
53 | nil) |
---|
54 | |# |
---|
55 | |
---|
56 | ;;; Test that setting the pprint dispatch of a symbol causes |
---|
57 | ;;; the printing to change, and that it can be unset. |
---|
58 | (deftest pprint-dispatch.3 |
---|
59 | (my-with-standard-io-syntax |
---|
60 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
61 | (*print-readably* nil) |
---|
62 | (*print-escape* nil) |
---|
63 | (*print-pretty* t)) |
---|
64 | (let ((f #'(lambda (stream obj) |
---|
65 | (declare (ignore obj)) |
---|
66 | (write "ABC" :stream stream)))) |
---|
67 | (values |
---|
68 | (write-to-string '|X|) |
---|
69 | (set-pprint-dispatch '(eql |X|) f) |
---|
70 | (write-to-string '|X|) |
---|
71 | (set-pprint-dispatch '(eql |X|) nil) |
---|
72 | (write-to-string '|X|))))) |
---|
73 | "X" nil "ABC" nil "X") |
---|
74 | |
---|
75 | ;;; Test that setting the pprint dispatch of a symbol causes |
---|
76 | ;;; the printing to change for any real weight, and that it can be unset. |
---|
77 | (deftest pprint-dispatch.4 |
---|
78 | (my-with-standard-io-syntax |
---|
79 | (loop for v1 in (remove-if-not #'realp *universe*) |
---|
80 | unless |
---|
81 | (equal |
---|
82 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
83 | (*print-readably* nil) |
---|
84 | (*print-escape* nil) |
---|
85 | (*print-pretty* t)) |
---|
86 | (let ((f #'(lambda (stream obj) |
---|
87 | (declare (ignore obj)) |
---|
88 | (write "ABC" :stream stream)))) |
---|
89 | (list |
---|
90 | (write-to-string '|X|) |
---|
91 | (set-pprint-dispatch '(eql |X|) f v1) |
---|
92 | (write-to-string '|X|) |
---|
93 | (set-pprint-dispatch '(eql |X|) nil) |
---|
94 | (write-to-string '|X|)))) |
---|
95 | '("X" nil "ABC" nil "X")) |
---|
96 | collect v1)) |
---|
97 | nil) |
---|
98 | |
---|
99 | ;;; Test that setting the pprint dispatch of a symbol causes |
---|
100 | ;;; the printing to change, and that it can be unset with any real weight |
---|
101 | (deftest pprint-dispatch.5 |
---|
102 | (my-with-standard-io-syntax |
---|
103 | (loop for v1 in (remove-if-not #'realp *universe*) |
---|
104 | unless |
---|
105 | (equal |
---|
106 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
107 | (*print-readably* nil) |
---|
108 | (*print-escape* nil) |
---|
109 | (*print-pretty* t)) |
---|
110 | (let ((f #'(lambda (stream obj) |
---|
111 | (declare (ignore obj)) |
---|
112 | (write "ABC" :stream stream)))) |
---|
113 | (list |
---|
114 | (write-to-string '|X|) |
---|
115 | (set-pprint-dispatch '(eql |X|) f) |
---|
116 | (write-to-string '|X|) |
---|
117 | (set-pprint-dispatch '(eql |X|) nil v1) |
---|
118 | (write-to-string '|X|)))) |
---|
119 | '("X" nil "ABC" nil "X")) |
---|
120 | collect v1)) |
---|
121 | nil) |
---|
122 | |
---|
123 | ;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch |
---|
124 | ;;; causes that table to be changed, not *print-pprint-dispatch*. |
---|
125 | (deftest pprint-dispatch.6 |
---|
126 | (my-with-standard-io-syntax |
---|
127 | (let ((other-ppd-table (copy-pprint-dispatch nil)) |
---|
128 | (*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
129 | (*print-readably* nil) |
---|
130 | (*print-escape* nil) |
---|
131 | (*print-pretty* t)) |
---|
132 | (let ((f #'(lambda (stream obj) |
---|
133 | (declare (ignore obj)) |
---|
134 | (write "ABC" :stream stream)))) |
---|
135 | (values |
---|
136 | (write-to-string '|X|) |
---|
137 | (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) |
---|
138 | (write-to-string '|X|) |
---|
139 | (let ((*print-pprint-dispatch* other-ppd-table)) |
---|
140 | (write-to-string '|X|)) |
---|
141 | (set-pprint-dispatch '(eql |X|) f) |
---|
142 | (write-to-string '|X|) |
---|
143 | (set-pprint-dispatch '(eql |X|) nil) |
---|
144 | (write-to-string '|X|))))) |
---|
145 | "X" nil "X" "ABC" nil "ABC" nil "X") |
---|
146 | |
---|
147 | ;;; Test that the default weight of set-pprint-dispatch is 0 |
---|
148 | |
---|
149 | (deftest pprint-dispatch.7 |
---|
150 | (my-with-standard-io-syntax |
---|
151 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
152 | (*print-readably* nil) |
---|
153 | (*print-escape* nil) |
---|
154 | (*print-pretty* t)) |
---|
155 | (let ((f #'(lambda (stream obj) |
---|
156 | (declare (ignore obj)) |
---|
157 | (write "ABC" :stream stream))) |
---|
158 | (g #'(lambda (stream obj) |
---|
159 | (declare (ignore obj)) |
---|
160 | (write "DEF" :stream stream)))) |
---|
161 | (values |
---|
162 | (write-to-string '|X|) |
---|
163 | (set-pprint-dispatch '(eql |X|) f) |
---|
164 | (write-to-string '|X|) |
---|
165 | (set-pprint-dispatch '(member |X| |Y|) g .0001) |
---|
166 | (write-to-string '|X|) |
---|
167 | (write-to-string '|Y|))))) |
---|
168 | "X" nil "ABC" nil "DEF" "DEF") |
---|
169 | |
---|
170 | (deftest pprint-dispatch.8 |
---|
171 | (my-with-standard-io-syntax |
---|
172 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
173 | (*print-readably* nil) |
---|
174 | (*print-escape* nil) |
---|
175 | (*print-pretty* t)) |
---|
176 | (let ((f #'(lambda (stream obj) |
---|
177 | (declare (ignore obj)) |
---|
178 | (write "ABC" :stream stream))) |
---|
179 | (g #'(lambda (stream obj) |
---|
180 | (declare (ignore obj)) |
---|
181 | (write "DEF" :stream stream)))) |
---|
182 | (values |
---|
183 | (write-to-string '|X|) |
---|
184 | (set-pprint-dispatch '(eql |X|) f) |
---|
185 | (write-to-string '|X|) |
---|
186 | (set-pprint-dispatch '(member |X| |Y|) g -.0001) |
---|
187 | (write-to-string '|X|) |
---|
188 | (write-to-string '|Y|))))) |
---|
189 | "X" nil "ABC" nil "ABC" "DEF") |
---|
190 | |
---|
191 | ;;; Funtion designators in pprint-dispatch |
---|
192 | |
---|
193 | (defun pprint-dispatch-test-fn.1 (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)) |
---|
194 | (defun pprint-dispatch-test-fn.2 (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)) |
---|
195 | |
---|
196 | (deftest pprint-dispatch.9 |
---|
197 | (my-with-standard-io-syntax |
---|
198 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
199 | (*print-readably* nil) |
---|
200 | (*print-escape* nil) |
---|
201 | (*print-pretty* t)) |
---|
202 | (values |
---|
203 | (write-to-string '|X|) |
---|
204 | (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1)) |
---|
205 | (write-to-string '|X|) |
---|
206 | (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.2)) |
---|
207 | (write-to-string '|X|)))) |
---|
208 | "X" (nil) "ABC" (nil) "DEF") |
---|
209 | |
---|
210 | #| |
---|
211 | (deftest pprint-dispatch.10 |
---|
212 | (my-with-standard-io-syntax |
---|
213 | (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) |
---|
214 | (*print-readably* nil) |
---|
215 | (*print-escape* nil) |
---|
216 | (*print-pretty* t)) |
---|
217 | (let ((f #'(lambda (stream obj) |
---|
218 | (declare (ignore obj)) |
---|
219 | (write "ABC" :stream stream))) |
---|
220 | (g #'(lambda (stream obj) |
---|
221 | (declare (ignore obj)) |
---|
222 | (write "DEF" :stream stream))) |
---|
223 | (sym (gensym))) |
---|
224 | (setf (symbol-function sym) f) |
---|
225 | (values |
---|
226 | (write-to-string '|X|) |
---|
227 | (set-pprint-dispatch '(eql |X|) sym) |
---|
228 | (write-to-string '|X|) |
---|
229 | (progn |
---|
230 | (setf (symbol-function sym) g) |
---|
231 | (write-to-string '|X|)))))) |
---|
232 | "X" nil "ABC" "DEF") |
---|
233 | |# |
---|
234 | |
---|
235 | ;;; Error tests |
---|
236 | |
---|
237 | (deftest pprint-dispatch.error.1 |
---|
238 | (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) |
---|
239 | (pprint-dispatch)) |
---|
240 | program-error) |
---|
241 | t) |
---|
242 | |
---|
243 | (deftest pprint-dispatch.error.2 |
---|
244 | (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) |
---|
245 | (pprint-dispatch nil nil nil)) |
---|
246 | program-error) |
---|
247 | t) |
---|
248 | |
---|
249 | (deftest set-pprint-dispatch.error.1 |
---|
250 | (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) |
---|
251 | (set-pprint-dispatch)) |
---|
252 | program-error) |
---|
253 | t) |
---|
254 | |
---|
255 | (deftest set-pprint-dispatch.error.2 |
---|
256 | (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) |
---|
257 | (set-pprint-dispatch t)) |
---|
258 | program-error) |
---|
259 | t) |
---|
260 | |
---|
261 | (deftest set-pprint-dispatch.error.3 |
---|
262 | (signals-error (let ((table (copy-pprint-dispatch nil))) |
---|
263 | (set-pprint-dispatch t 'identity 0 table nil)) |
---|
264 | program-error) |
---|
265 | t) |
---|
266 | |
---|
267 | |
---|
268 | (deftest set-pprint-dispatch.error.4 |
---|
269 | (loop for x in *mini-universe* |
---|
270 | unless (or (typep x 'real) |
---|
271 | (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) |
---|
272 | (set-pprint-dispatch t 'identity ',x)) |
---|
273 | error))) |
---|
274 | collect x) |
---|
275 | nil) |
---|
276 | |
---|
277 | (deftest set-pprint-dispatch.error.4-unsafe |
---|
278 | (loop for x in *mini-universe* |
---|
279 | unless (or (typep x 'real) |
---|
280 | (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) |
---|
281 | (declare (optimize (safety 0))) |
---|
282 | (set-pprint-dispatch t 'identity ',x)) |
---|
283 | error))) |
---|
284 | collect x) |
---|
285 | nil) |
---|
286 | |
---|