| 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 | |
|---|
