source: trunk/source/tests/ansi-tests/pprint-dispatch.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 8.2 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.