pprint-dispatch.lsp 10.1 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Jun 12 13:14:53 2004
;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH

(in-package :cl-test)

(deftest pprint-dispatch.1
9
  (loop for x in (append *universe* *cl-symbols*)
sds's avatar
sds committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
        for vals = (multiple-value-list (pprint-dispatch x))
        for vals2 = (multiple-value-list (pprint-dispatch
                                          x
                                          *print-pprint-dispatch*))
        unless
        (and (= (length vals) 2)
             (= (length vals2) 2)
             (destructuring-bind (fun foundp)
                 vals
               (if foundp
                   (and (or (typep fun 'function)
                            (and (symbolp fun)
                                 (symbol-function fun)))
                        (destructuring-bind (fun2 foundp2)
                            vals2
                          (and (equal fun fun2)
                               foundp2)))
                 (not (cadr vals2)))))
        collect (list x vals vals2))
pfdietz's avatar
pfdietz committed
29
  nil)
30
#|
pfdietz's avatar
pfdietz committed
31 32
(deftest pprint-dispatch.2
  (loop for sym in *cl-symbols*
sds's avatar
sds committed
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
        for x = (list sym nil nil)
        for vals = (multiple-value-list (pprint-dispatch x))
        for vals2 = (multiple-value-list (pprint-dispatch
                                          x
                                          *print-pprint-dispatch*))
        unless
        (and (= (length vals) 2)
             (= (length vals2) 2)
             (destructuring-bind (fun foundp)
                 vals
               (if foundp
                   (and (or (typep fun 'function)
                            (and (symbolp fun)
                                 (symbol-function fun)))
                        (destructuring-bind (fun2 foundp2)
                            vals2
                          (and (equal fun fun2)
                               foundp2)))
                 (not (cadr vals2)))))
        collect (list x vals vals2))
pfdietz's avatar
pfdietz committed
53
  nil)
54
|#
pfdietz's avatar
pfdietz committed
55

56 57
;;; Test that setting the pprint dispatch of a symbol causes
;;; the printing to change, and that it can be unset.
pfdietz's avatar
pfdietz committed
58 59 60
(deftest pprint-dispatch.3
  (my-with-standard-io-syntax
   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
sds's avatar
sds committed
61 62 63
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
pfdietz's avatar
pfdietz committed
64
     (let ((f #'(lambda (stream obj)
sds's avatar
sds committed
65 66
                  (declare (ignore obj))
                  (write "ABC" :stream stream))))
pfdietz's avatar
pfdietz committed
67
       (values
sds's avatar
sds committed
68 69 70 71 72
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) f)
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) nil)
        (write-to-string '|X|)))))
pfdietz's avatar
pfdietz committed
73
  "X" nil "ABC" nil "X")
sds's avatar
sds committed
74

75 76
;;; Test that setting the pprint dispatch of a symbol causes
;;; the printing to change for any real weight, and that it can be unset.
pfdietz's avatar
pfdietz committed
77 78
(deftest pprint-dispatch.4
  (my-with-standard-io-syntax
79
   (loop for v1 in (remove-if-not #'realp *universe*)
sds's avatar
sds committed
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
         unless
         (equal
          (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
                (*print-readably* nil)
                (*print-escape* nil)
                (*print-pretty* t))
            (let ((f #'(lambda (stream obj)
                         (declare (ignore obj))
                         (write "ABC" :stream stream))))
              (list
               (write-to-string '|X|)
               (set-pprint-dispatch '(eql |X|) f v1)
               (write-to-string '|X|)
               (set-pprint-dispatch '(eql |X|) nil)
               (write-to-string '|X|))))
          '("X" nil "ABC" nil "X"))
         collect v1))
pfdietz's avatar
pfdietz committed
97
  nil)
sds's avatar
sds committed
98

99 100
;;; Test that setting the pprint dispatch of a symbol causes
;;; the printing to change, and that it can be unset with any real weight
pfdietz's avatar
pfdietz committed
101 102
(deftest pprint-dispatch.5
  (my-with-standard-io-syntax
103
   (loop for v1 in (remove-if-not #'realp *universe*)
sds's avatar
sds committed
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
         unless
         (equal
          (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
                (*print-readably* nil)
                (*print-escape* nil)
                (*print-pretty* t))
            (let ((f #'(lambda (stream obj)
                         (declare (ignore obj))
                         (write "ABC" :stream stream))))
              (list
               (write-to-string '|X|)
               (set-pprint-dispatch '(eql |X|) f)
               (write-to-string '|X|)
              (set-pprint-dispatch '(eql |X|) nil v1)
              (write-to-string '|X|))))
          '("X" nil "ABC" nil "X"))
         collect v1))
pfdietz's avatar
pfdietz committed
121 122
  nil)

123 124
;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch
;;; causes that table to be changed, not *print-pprint-dispatch*.
pfdietz's avatar
pfdietz committed
125 126 127
(deftest pprint-dispatch.6
  (my-with-standard-io-syntax
   (let ((other-ppd-table (copy-pprint-dispatch nil))
sds's avatar
sds committed
128 129 130 131
         (*print-pprint-dispatch* (copy-pprint-dispatch nil))
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
pfdietz's avatar
pfdietz committed
132
     (let ((f #'(lambda (stream obj)
sds's avatar
sds committed
133 134
                  (declare (ignore obj))
                  (write "ABC" :stream stream))))
pfdietz's avatar
pfdietz committed
135
       (values
sds's avatar
sds committed
136 137 138 139 140 141 142 143 144
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table)
        (write-to-string '|X|)
        (let ((*print-pprint-dispatch* other-ppd-table))
          (write-to-string '|X|))
        (set-pprint-dispatch '(eql |X|) f)
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) nil)
        (write-to-string '|X|)))))
pfdietz's avatar
pfdietz committed
145
  "X" nil "X" "ABC" nil "ABC" nil "X")
146 147 148 149 150 151

;;; Test that the default weight of set-pprint-dispatch is 0

(deftest pprint-dispatch.7
  (my-with-standard-io-syntax
   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
sds's avatar
sds committed
152 153 154
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
155
     (let ((f #'(lambda (stream obj)
sds's avatar
sds committed
156 157 158 159 160
                  (declare (ignore obj))
                  (write "ABC" :stream stream)))
           (g #'(lambda (stream obj)
                  (declare (ignore obj))
                  (write "DEF" :stream stream))))
161
       (values
sds's avatar
sds committed
162 163 164 165 166 167
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) f)
        (write-to-string '|X|)
        (set-pprint-dispatch '(member |X| |Y|) g .0001)
        (write-to-string '|X|)
        (write-to-string '|Y|)))))
168 169 170 171 172
  "X" nil "ABC" nil "DEF" "DEF")

(deftest pprint-dispatch.8
  (my-with-standard-io-syntax
   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
sds's avatar
sds committed
173 174 175
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
176
     (let ((f #'(lambda (stream obj)
sds's avatar
sds committed
177 178 179 180 181
                  (declare (ignore obj))
                  (write "ABC" :stream stream)))
           (g #'(lambda (stream obj)
                  (declare (ignore obj))
                  (write "DEF" :stream stream))))
182
       (values
sds's avatar
sds committed
183 184 185 186 187 188
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) f)
        (write-to-string '|X|)
        (set-pprint-dispatch '(member |X| |Y|) g -.0001)
        (write-to-string '|X|)
        (write-to-string '|Y|)))))
189 190
  "X" nil "ABC" nil "ABC" "DEF")

pfdietz's avatar
pfdietz committed
191
;;; Funtion designators in pprint-dispatch
192

pfdietz's avatar
pfdietz committed
193 194 195 196 197 198
(defun pprint-dispatch-test-fn.1 (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))
(defun pprint-dispatch-test-fn.2 (stream obj) (declare (ignore obj)) (write "DEF" :stream stream))

(deftest pprint-dispatch.9
  (my-with-standard-io-syntax
   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
sds's avatar
sds committed
199 200 201
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
pfdietz's avatar
pfdietz committed
202 203 204 205 206 207 208 209
     (values
      (write-to-string '|X|)
      (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1))
      (write-to-string '|X|)
      (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.2))
      (write-to-string '|X|))))
  "X" (nil) "ABC" (nil) "DEF")

210
#|
pfdietz's avatar
pfdietz committed
211 212 213
(deftest pprint-dispatch.10
  (my-with-standard-io-syntax
   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
sds's avatar
sds committed
214 215 216
         (*print-readably* nil)
         (*print-escape* nil)
         (*print-pretty* t))
pfdietz's avatar
pfdietz committed
217
     (let ((f #'(lambda (stream obj)
sds's avatar
sds committed
218 219 220 221 222 223
                  (declare (ignore obj))
                  (write "ABC" :stream stream)))
           (g #'(lambda (stream obj)
                  (declare (ignore obj))
                  (write "DEF" :stream stream)))
           (sym (gensym)))
pfdietz's avatar
pfdietz committed
224 225
       (setf (symbol-function sym) f)
       (values
sds's avatar
sds committed
226 227 228 229 230 231
        (write-to-string '|X|)
        (set-pprint-dispatch '(eql |X|) sym)
        (write-to-string '|X|)
        (progn
          (setf (symbol-function sym) g)
          (write-to-string '|X|))))))
pfdietz's avatar
pfdietz committed
232
  "X" nil "ABC" "DEF")
233
|#
pfdietz's avatar
pfdietz committed
234 235 236 237 238

;;; Error tests

(deftest pprint-dispatch.error.1
  (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
sds's avatar
sds committed
239 240
                   (pprint-dispatch))
                 program-error)
pfdietz's avatar
pfdietz committed
241 242 243 244
  t)

(deftest pprint-dispatch.error.2
  (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
sds's avatar
sds committed
245 246
                   (pprint-dispatch nil nil nil))
                 program-error)
pfdietz's avatar
pfdietz committed
247
  t)
248

249 250
(deftest set-pprint-dispatch.error.1
  (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
sds's avatar
sds committed
251 252
                   (set-pprint-dispatch))
                 program-error)
253 254 255 256
  t)

(deftest set-pprint-dispatch.error.2
  (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
sds's avatar
sds committed
257 258
                   (set-pprint-dispatch t))
                 program-error)
259 260 261 262
  t)

(deftest set-pprint-dispatch.error.3
  (signals-error (let ((table (copy-pprint-dispatch nil)))
sds's avatar
sds committed
263 264
                   (set-pprint-dispatch t 'identity 0 table nil))
                 program-error)
265 266 267
  t)


268 269
(deftest set-pprint-dispatch.error.4
  (loop for x in *mini-universe*
sds's avatar
sds committed
270 271 272 273 274
        unless (or (typep x 'real)
                   (eval `(signals-error (let ((table (copy-pprint-dispatch nil)))
                                           (set-pprint-dispatch t 'identity ',x))
                                         error)))
        collect x)
275
  nil)
276

277 278
(deftest set-pprint-dispatch.error.4-unsafe
  (loop for x in *mini-universe*
sds's avatar
sds committed
279 280 281 282 283 284
        unless (or (typep x 'real)
                   (eval `(signals-error (let ((table (copy-pprint-dispatch nil)))
                                           (declare (optimize (safety 0)))
                                           (set-pprint-dispatch t 'identity ',x))
                                         error)))
        collect x)
285
  nil)
286