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