1;; -*- Lisp -*- vim:filetype=lisp 2;; restarts 3(defun handler-use-value (value) 4 (lambda (c) (princ-error c) (use-value value))) 5HANDLER-USE-VALUE 6(defmacro check-use-value (fun good bad &key (type 'type-error) (test 'eql)) 7 `(handler-bind ((,type (handler-use-value ',good))) 8 (,test (,fun ',good) (,fun ',bad)))) 9CHECK-USE-VALUE 10 11(check-use-value char-code #\1 12 :test =) t 12(check-use-value symbol-name good "bad" :test string=) t 13(check-use-value intern "BAR" bar :test eq) t 14(check-use-value fboundp cons "CONS") t 15(check-use-value fdefinition cons "CONS") t 16(check-use-value string "123" 123) t 17 18(check-use-value (lambda (a) (aref a 2)) #(a b c d) 1) t 19(check-use-value (lambda (a) (setf (aref a 2) 'x)) #(a b c d) 1) t 20(check-use-value (lambda (a) (row-major-aref a 3)) #2A((a b) (c d)) 1) t 21(check-use-value (lambda (a) (setf (row-major-aref a 3) 'x)) #2A((a b) (c d)) 1) t 22(check-use-value array-element-type #*1001 1) t 23(check-use-value array-rank #(a b c d) 1) t 24(check-use-value (lambda (a) (array-dimension a 1)) #2A((a b) (c d)) 1) t 25(check-use-value array-dimensions #2A((a b) (c d)) 1 :test equal) t 26(check-use-value (lambda (a) (array-in-bounds-p a 1 2)) #2A((a b) (c d)) 1) t 27(check-use-value (lambda (a) (array-row-major-index a 2)) #(a b c d) 1) t 28(check-use-value (lambda (a) (array-row-major-index a 1 1)) #2A((a b) (c d)) 1) t 29(check-use-value adjustable-array-p #2A((a b) (c d)) 1) t 30(check-use-value (lambda (a) (bit a 2)) #*1011 1) t 31(check-use-value (lambda (a) (sbit a 2)) #*1011 1) t 32(check-use-value array-has-fill-pointer-p #2A((a b) (c d)) 1) t 33 34(let ((bs (make-broadcast-stream))) 35 (handler-bind ((type-error (handler-use-value bs))) 36 (broadcast-stream-streams 10))) 37NIL 38 39(handler-bind ((error (handler-use-value #\#))) 40 (eq (get-dispatch-macro-character #\a #\() 41 (get-dispatch-macro-character #\# #\())) 42T 43 44(with-output-to-string (o) 45 (handler-bind ((type-error (handler-use-value o))) 46 (princ "no error!" 123))) 47"no error!" 48 49(handler-bind ((type-error (handler-use-value 16))) 50 (parse-integer "ABC" :radix 'lambda)) 512748 52 53(with-input-from-string (s "bazonk") 54 (handler-bind ((type-error (handler-use-value s))) 55 (list (read-char 123) (read-char 1) (read-char 'read-char)))) 56(#\b #\a #\z) 57 58(handler-bind 59 ((type-error 60 (lambda (c) 61 (princ-error c) 62 (use-value 63 (case (type-error-datum c) 64 (1 *readtable*) 65 (2 :upcase) 66 (t (error "huh?"))))))) 67 (setf (readtable-case 1) 2)) 68:UPCASE 69 70(handler-bind 71 ((type-error 72 (lambda (c) 73 (princ-error c) 74 (use-value 75 (case (type-error-datum c) 76 (1 #\#) 77 (2 *readtable*) 78 (t (error "huh?"))))))) 79 (nth-value 1 (get-macro-character 1 2))) 80T 81 82(handler-bind ((type-error (handler-use-value 7))) 83 (list (digit-char-p #\3 300) 84 (digit-char-p #\8 'digit-char-p))) 85(3 NIL) 86 87(handler-bind ((type-error 88 (lambda (c) 89 (princ-error c) 90 (use-value (char (type-error-datum c) 0))))) 91 (list (char= "abc" "a") 92 (char-equal "ABC" "a"))) 93(T T) 94 95(handler-bind ((type-error 96 (lambda (c) 97 (princ-error c) 98 (use-value (string (type-error-datum c)))))) 99 (ext:string-concat "foo-" 'bar "-baz")) 100"foo-BAR-baz" 101 102(handler-bind ((undefined-function 103 (lambda (c) (princ-error c) 104 (store-value 105 (lambda (new-car pair) 106 (setf (car pair) new-car)))))) 107 (let ((a '(1 . 2))) 108 (setf (zz a) 12) 109 a)) 110(12 . 2) 111(fmakunbound '(setf zz)) (setf zz) 112 113(handler-bind ((undefined-function 114 (lambda (c) (princ-error c) (store-value #'car)))) 115 (zz '(1 . 2))) 1161 117(fmakunbound 'zz) zz 118 119(defun use-value-read (c) 120 (princ-error c) 121 (use-value (read-from-string 122 (etypecase c 123 (sys::source-program-error (sys::source-program-error-form c)) 124 (type-error (type-error-datum c)) 125 (cell-error (cell-error-name c)))))) 126use-value-read 127 128(let ((table (copy-readtable nil))) 129 (and (eq :upcase (readtable-case table)) 130 (setf (readtable-case table) :invert) 131 (let ((copy (copy-readtable table))) 132 (and (not (eq table copy)) 133 (eq (readtable-case copy) :invert))))) 134T 135 136(handler-bind ((type-error #'use-value-read)) 137 (setf (readtable-case (copy-readtable nil)) ":UPCASE")) 138:UPCASE 139 140(handler-bind ((error (handler-use-value '+))) 141 (eval '(function "+"))) 142#.#'+ 143 144(handler-bind ((error #'use-value-read)) 145 (funcall "+" 1 2 3)) 1466 147 148;; progv 149(handler-bind ((type-error #'use-value-read)) 150 (progv '("foo") '(123) foo)) 151123 152 153(handler-bind ((program-error (handler-use-value 'zz))) 154 (progv '(:const-var) '(123) zz)) 155123 156 157(let ((form '(progv '("foo" :const) '(123 321) (+ foo zz)))) 158 (handler-bind ((type-error #'use-value-read) 159 (program-error (handler-use-value 'zz))) 160 (list (eval form) form))) 161(444 (progv '("foo" :const) '(123 321) (+ foo zz))) 162 163(handler-bind ((type-error #'use-value-read)) 164 (multiple-value-setq (baz "foo") (values 123 321)) 165 (list foo baz)) 166(321 123) 167 168(handler-bind ((program-error (handler-use-value 'zz))) 169 (setq :const-var 125) 170 zz) 171125 172 173(handler-bind ((program-error (handler-use-value '(zz 48)))) 174 (let (("foo" 32)) zz)) 17548 176 177;; This test reflects only the current CLISP behaviour: 178;; - It can be argued that zz should be bound statically (since zz 179;; is not declared special) or should be bound dynamically (since :const-var 180;; would be bound dynamically and zz replaces just the symbol). 181;; - It can be argued that later zz should be evaluated statically (because 182;; that's what normal EVAL in the interpreter would do) or should be 183;; evaluated to lookup (symbol-value 'zz) - since that's what the compiler 184;; would make from the code. 185(handler-bind ((program-error (handler-use-value 'zz))) 186 (let ((:const-var 64)) zz)) 18764 188 189;; either TYPE-ERROR or SOURCE-PROGRAM-ERROR is reasonable here 190;; (handler-bind ((source-program-error #'use-value-read) 191;; (type-error #'use-value-read)) 192;; ((lambda (x "y") (+ x y)) 1 3)) 193;; 4 194 195;; (handler-bind ((source-program-error #'use-value-read) 196;; (type-error #'use-value-read)) 197;; ((lambda (x &optional ("y" 10)) (+ x y)) 1 3)) 198;; 4 199 200;; (handler-bind ((source-program-error #'use-value-read) 201;; (type-error #'use-value-read)) 202;; ((lambda (x &key ("y" 10)) (+ x y)) 1 :y 3)) 203;; 4 204 205;; (handler-bind ((source-program-error #'use-value-read) 206;; (type-error #'use-value-read)) 207;; ((lambda (x &aux ("y" 10)) (+ x y)) 1)) 208;; 11 209 210;; (handler-bind ((source-program-error #'use-value-read) 211;; (type-error #'use-value-read)) 212;; (let ((f (lambda ("a" &optional "b" ("c" 1) &rest "d" 213;; &key "e" ("f" 2) ("g" 3 "gp") (("hk" "ha") 4 "hp") 214;; ("i" 5 "ip") 215;; &aux ("j" 6)) 216;; (list a b c '&rest d 'e e 'f f 'g g gp 'h ha hp 'i i ip 'j j)))) 217;; (print f) 218;; (funcall f 11 22 33 :e 44 :g 55 'hk 66))) 219;; (11 22 33 &REST (:E 44 :G 55 HK 66) E 44 F 2 G 55 T H 66 T I 5 NIL J 6) 220 221(handler-bind ((type-error #'use-value-read) 222 (source-program-error #'use-value-read)) 223 (funcall "CAR" '(1 . 1))) 2241 225 226(handler-bind ((type-error #'use-value-read) 227 (source-program-error #'use-value-read)) 228 (setq "FOO" 1) 229 (symbol-value 'foo)) 2301 231 232;; https://sourceforge.net/p/clisp/bugs/539/ 233(let ((count 5)) 234 (flet ((handler (c) 235 (princ-error c) 236 (decf count) 237 (use-value (if (zerop count) 'x count)))) 238 (handler-bind ((program-error #'handler) 239 (type-error #'handler)) 240 (setq :const-var 12))) 241 (list count x)) 242(0 12) 243 244;; make-hash-table 245(flet ((mht (test) (make-hash-table :test test))) 246 (check-use-value mht eql bazonk :test equalp)) t 247(flet ((mht (w) (make-hash-table :weak w))) 248 (check-use-value mht nil bazonk :test equalp)) t 249(flet ((mht (s) (make-hash-table :size s))) 250 (check-use-value mht 10 bazonk :test equalp)) t 251(flet ((mht (rs) (make-hash-table :rehash-size rs))) 252 (check-use-value mht 2d0 bazonk :test equalp)) t 253(flet ((mht (tr) (make-hash-table :rehash-threshold tr))) 254 (check-use-value mht 5d-1 bazonk :test equalp)) t 255 256(handler-bind ((program-error (handler-use-value '1+)) 257 (type-error (handler-use-value '1-))) 258 (list (eval '(1 10)) (funcall 1 100) (apply 1 '(1000)))) 259(11 99 999) 260 261(progn (makunbound 'bar) 262(handler-bind ((unbound-variable 263 (lambda (c) (princ-error c) (store-value 41)))) 264 (1+ bar))) 26542 266 267bar 41 268 269(progn 270 (defclass zot () (zot-foo)) 271 (setq bar (make-instance 'zot)) 272 (handler-bind ((unbound-slot 273 (lambda (c) (princ-error c) (store-value 41)))) 274 (1+ (slot-value bar 'zot-foo)))) 27542 276 277(slot-value bar 'zot-foo) 41 278 279(progn 280 (define-condition xyzzy () 281 ((f1 :accessor my-f1 :initarg :f1-is)) 282 (:report (lambda (c s) 283 (format s "~1Txyzzy: My f1 is ~A" (my-f1 c))))) 284 (princ-to-string (make-condition 'xyzzy :f1-is "a silly string"))) 285" xyzzy: My f1 is a silly string" 286 287;; check all invocations of correctable-error in package.d 288(let* ((p1 (make-package "PACK-1" :use nil)) 289 (p2 (make-package "PACK-2" :use nil)) 290 (p3 (make-package "PACK-3" :use nil)) 291 (p4 (make-package "PACK-4" :use nil)) 292 (p5 (make-package "PACK-5" :use nil)) 293 (bar-name (symbol-name (gensym "BAR-"))) 294 (foo1 (intern "FOO" p1)) (foo2 (intern "FOO" p2)) 295 (bar1 (intern bar-name p1)) (bar2 (intern bar-name p2)) 296 (bar3 (intern bar-name p3)) (bar4 (intern bar-name p4)) 297 (s12 (intern "SYM-1" p2)) (s22 (intern "SYM-2" p2)) 298 (s13 (intern "SYM-1" p3)) (s23 (intern "SYM-2" p3)) 299 (s14 (intern "SYM-1" p4)) (s24 (intern "SYM-2" p4)) 300 (s15 (intern "SYM-1" p5)) (s25 (intern "SYM-2" p5))) 301 (export (list s12 s22) p2) 302 (export (list s13 s23) p3) 303 (export (list s14 s24) p4) 304 (handler-bind ((package-error 305 (lambda (c) (princ-error c) (invoke-restart :pack-3)))) 306 (use-package (list p2 p3 p4) p1)) 307 (assert (null (set-exclusive-or (list p2 p3 p4) (package-use-list p1)))) 308 (assert (eq (find-symbol "SYM-1" p1) s13)) 309 (assert (eq (find-symbol "SYM-2" p1) s23)) 310 (handler-bind ((package-error 311 (lambda (c) (princ-error c) (invoke-restart 'import)))) 312 (export s15 p1)) 313 (assert (eq (find-symbol "SYM-1" p1) s15)) 314 (handler-bind ((package-error 315 (lambda (c) (princ-error c) (invoke-restart :pack-2)))) 316 (export foo2 p2)) 317 (assert (eq (find-symbol "FOO" p1) foo2)) 318 (assert (null (set-exclusive-or (list bar1 bar2 bar3 bar4) 319 (find-all-symbols bar-name)))) 320 (handler-bind ((package-error 321 (lambda (c) (princ-error c) (invoke-restart :pack-1)))) 322 (export bar2 p2)) 323 (assert (eq (find-symbol bar-name p1) bar1)) 324 (export bar3 p3) 325 (export bar4 p4) 326 (handler-bind ((package-error 327 (lambda (c) (princ-error c) (invoke-restart :pack-4)))) 328 (unintern bar1 p1)) 329 (assert (eq (find-symbol bar-name p1) bar4)) 330 (delete-package p5) 331 (handler-bind ((package-error (lambda (c) (princ-error c) (continue c)))) 332 (delete-package p2) (delete-package p3) (delete-package p4)) 333 (delete-package p1)) 334T 335 336(let ((p1 (make-package "PACK" :use nil)) p2 p3 p4 337 (bar-name (symbol-name (gensym "BAR-")))) 338 (handler-bind ((package-error 339 (lambda (c) (princ-error c) (invoke-restart 'continue)))) 340 (assert (eq p1 (make-package "PACK")))) 341 (handler-bind ((package-error 342 (lambda (c) (princ-error c) (invoke-restart 'read "KCAP")))) 343 (setq p2 (make-package "PACK"))) 344 (assert (string= "KCAP" (package-name p2))) 345 (handler-bind ((package-error 346 (lambda (c) (princ-error c) (invoke-restart 'continue)))) 347 (setq p3 (make-package "FOO" :nicknames (list "CL" bar-name "KCAP")))) 348 (assert (equal (list bar-name) (package-nicknames p3))) 349 (handler-bind ((package-error 350 (lambda (c) (princ-error c) (invoke-restart 'read "ZOT")))) 351 (setq p4 (make-package "QUUX" :nicknames (list "CL" bar-name "KCAP")))) 352 (assert (equal (list "ZOT") (package-nicknames p4))) 353 (delete-package p1) (delete-package p2) 354 (delete-package p3) (delete-package p4)) 355T 356 357(handler-bind ((error (handler-use-value '(9 8 7 6)))) 358 (list (butlast 123 2) 359 (butlast '#1=(1 2 3 . #1#) 2) 360 (last 123 2) 361 (last '#1# 2))) 362((9 8) (9 8) (7 6) (7 6)) 363 364(handler-bind ((error (handler-use-value 'check-use-value))) 365 (setf (documentation '(check-use-value) 'function) 366 "docstring for check-use-value") 367 (documentation 'check-use-value 'function)) 368"docstring for check-use-value" 369 370(handler-bind ((error (handler-use-value 'use-value-read))) 371 (setf (documentation '(use-value-read) 'function) 372 "docstring for use-value-read") 373 (documentation 'use-value-read 'function)) 374"docstring for use-value-read" 375 376(macrolet ((u (v) `(handler-use-value ,v))) 377 (handler-bind ((type-error (u "docstring for use-value-read")) 378 (error (u 'use-value-read))) 379 (string= '(foo) (documentation '(foo) 'function)))) 380T 381 382(symbol-macrolet ((u (handler-use-value 1))) 383 (handler-bind ((type-error u)) 384 (+ 'symbol-macrolet 'handler-bind 'type-error))) 3853 386 387(symbols-cleanup '(check-use-value use-value-read zot foo bar baz xyzzy)) 388() 389