1 ;;;; that part of the condition system which can or should come early
2 ;;;; (mostly macro-related)
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
17 ;;; a list of lists of restarts
18 (defvar *restart-clusters* '())
20 ;;; An ALIST (condition . restarts) which records the restarts currently
21 ;;; associated with Condition.
22 (defvar *condition-restarts* ())
24 (defun compute-restarts (&optional condition)
26 "Return a list of all the currently active restarts ordered from most
27 recently established to less recently established. If Condition is
28 specified, then only restarts associated with Condition (or with no
29 condition) will be returned."
32 (dolist (alist *condition-restarts*)
33 (if (eq (car alist) condition)
34 (setq associated (cdr alist))
35 (setq other (append (cdr alist) other))))
37 (dolist (restart-cluster *restart-clusters*)
38 (dolist (restart restart-cluster)
39 (when (and (or (not condition)
40 (member restart associated)
41 (not (member restart other)))
42 (funcall (restart-test-function restart) condition))
46 (defstruct (restart (:copier nil))
51 (test-function #'(lambda (cond) (declare (ignore cond)) t)))
52 (def!method print-object ((restart restart) stream)
54 (print-unreadable-object (restart stream :type t :identity t))
55 (restart-report restart stream)))
58 (setf (fdocumentation 'restart-name 'function)
59 "Returns the name of the given restart object.")
61 (defun restart-report (restart stream)
62 (funcall (or (restart-report-function restart)
63 (let ((name (restart-name restart)))
65 (if name (format stream "~S" name)
66 (format stream "~S" restart)))))
69 (defmacro with-condition-restarts (condition-form restarts-form &body body)
71 "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
72 Evaluates the Forms in a dynamic environment where the restarts in the list
73 Restarts-Form are associated with the condition returned by Condition-Form.
74 This allows FIND-RESTART, etc., to recognize restarts that are not related
75 to the error currently being debugged. See also RESTART-CASE."
76 (let ((n-cond (gensym)))
77 `(let ((*condition-restarts*
78 (cons (let ((,n-cond ,condition-form))
80 (append ,restarts-form
81 (cdr (assoc ,n-cond *condition-restarts*)))))
82 *condition-restarts*)))
85 (defmacro restart-bind (bindings &body forms)
87 "Executes forms in a dynamic context where the given restart bindings are
88 in effect. Users probably want to use RESTART-CASE. When clauses contain
89 the same restart name, FIND-RESTART will find the first such clause."
90 `(let ((*restart-clusters*
92 ,@(mapcar #'(lambda (binding)
93 (unless (or (car binding)
94 (member :report-function
97 (warn "Unnamed restart does not have a ~
101 :name ',(car binding)
102 :function ,(cadr binding)
105 *restart-clusters*)))
108 (defun find-restart (name &optional condition)
110 "Returns the first restart named name. If name is a restart, it is returned
111 if it is currently active. If no such restart is found, nil is returned.
112 It is an error to supply nil as a name. If Condition is specified and not
113 NIL, then only restarts associated with that condition (or with no
114 condition) will be returned."
115 (find-if #'(lambda (x)
117 (eq (restart-name x) name)))
118 (compute-restarts condition)))
120 (defun invoke-restart (restart &rest values)
122 "Calls the function associated with the given restart, passing any given
123 arguments. If the argument restart is not a restart or a currently active
124 non-nil restart name, then a control-error is signalled."
125 (let ((real-restart (find-restart restart)))
127 (error 'simple-control-error
128 :format-control "Restart ~S is not active."
129 :format-arguments (list restart)))
130 (apply (restart-function real-restart) values)))
132 (defun invoke-restart-interactively (restart)
134 "Calls the function associated with the given restart, prompting for any
135 necessary arguments. If the argument restart is not a restart or a
136 currently active non-nil restart name, then a control-error is signalled."
137 (let ((real-restart (find-restart restart)))
139 (error 'simple-control-error
140 :format-control "Restart ~S is not active."
141 :format-arguments (list restart)))
142 (apply (restart-function real-restart)
143 (let ((interactive-function
144 (restart-interactive-function real-restart)))
145 (if interactive-function
146 (funcall interactive-function)
149 (eval-when (:compile-toplevel :load-toplevel :execute)
150 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
151 ;;; appropriate. Gross, but it's what the book seems to say...
152 (defun munge-restart-case-expression (expression data)
153 (let ((exp (macroexpand expression)))
155 (let* ((name (car exp))
156 (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
157 (if (member name '(signal error cerror warn))
158 (once-only ((n-cond `(coerce-to-condition
162 (warn 'simple-warning)
163 (signal 'simple-condition)
166 `(with-condition-restarts
168 (list ,@(mapcar (lambda (da)
169 `(find-restart ',(nth 0 da)))
171 ,(if (eq name 'cerror)
172 `(cerror ,(second expression) ,n-cond)
178 ;;; FIXME: I did a fair amount of rearrangement of this code in order to
179 ;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
180 (defmacro restart-case (expression &body clauses)
183 {(case-name arg-list {keyword value}* body)}*)
184 The form is evaluated in a dynamic context where the clauses have special
185 meanings as points to which control may be transferred (see INVOKE-RESTART).
186 When clauses contain the same case-name, FIND-RESTART will find the first
187 such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
188 macroexpands into such) then the signalled condition will be associated with
190 (flet ((transform-keywords (&key report interactive test)
193 (setq result (list* (if (stringp report)
195 (write-string ,report stream))
200 (setq result (list* `#',interactive
201 :interactive-function
204 (setq result (list* `#',test
208 (parse-keyword-pairs (list keys)
209 (do ((l list (cddr l))
210 (k '() (list* (cadr l) (car l) k)))
211 ((or (null l) (not (member (car l) keys)))
212 (values (nreverse k) l)))))
213 (let ((block-tag (gensym))
216 (macrolet (;; KLUDGE: This started as an old DEFMACRO
217 ;; WITH-KEYWORD-PAIRS general utility, which was used
218 ;; only in this one place in the code. It was translated
219 ;; literally into this MACROLET in order to avoid some
220 ;; cross-compilation bootstrap problems. It would almost
221 ;; certainly be clearer, and it would certainly be more
222 ;; concise, to do a more idiomatic translation, merging
223 ;; this with the TRANSFORM-KEYWORDS logic above.
225 (with-keyword-pairs ((names expression) &body forms)
226 (let ((temp (member '&rest names)))
227 (unless (= (length temp) 2)
228 (error "&REST keyword is ~:[missing~;misplaced~]."
230 (let* ((key-vars (ldiff names temp))
231 (keywords (mapcar #'keywordicate key-vars))
233 (rest-var (cadr temp)))
234 `(multiple-value-bind (,key-var ,rest-var)
235 (parse-keyword-pairs ,expression ',keywords)
236 (let ,(mapcar (lambda (var keyword)
237 `(,var (getf ,key-var
241 (mapcar (lambda (clause)
242 (with-keyword-pairs ((report interactive test
245 (list (car clause) ;name=0
247 (transform-keywords :report report ;keywords=2
248 :interactive interactive
254 (let ((,temp-var nil))
257 ,(mapcar #'(lambda (datum)
258 (let ((name (nth 0 datum))
260 (keys (nth 2 datum)))
261 `(,name #'(lambda (&rest temp)
262 (setq ,temp-var temp)
266 (return-from ,block-tag
267 ,(munge-restart-case-expression expression data)))
268 ,@(mapcan #'(lambda (datum)
269 (let ((tag (nth 1 datum))
271 (body (nth 4 datum)))
273 `(return-from ,block-tag
274 (apply #'(lambda ,bvl ,@body)
278 (defmacro with-simple-restart ((restart-name format-string
279 &rest format-arguments)
282 "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
284 If restart-name is not invoked, then all values returned by forms are
285 returned. If control is transferred to this restart, it immediately
286 returns the values nil and t."
288 ;; If there's just one body form, then don't use PROGN. This allows
289 ;; RESTART-CASE to "see" calls to ERROR, etc.
290 ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
292 :report (lambda (stream)
293 (format stream ,format-string ,@format-arguments))
298 (defvar *handler-clusters* nil)
300 (defmacro handler-bind (bindings &body forms)
302 "(HANDLER-BIND ( {(type handler)}* ) body)
303 Executes body in a dynamic context where the given handler bindings are
304 in effect. Each handler must take the condition being signalled as an
305 argument. The bindings are searched first to last in the event of a
306 signalled condition."
307 (let ((member-if (member-if (lambda (x)
308 (not (proper-list-of-length-p x 2)))
311 (error "ill-formed handler binding: ~S" (first member-if))))
312 `(let ((*handler-clusters*
313 (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
315 *handler-clusters*)))
316 (multiple-value-prog1
319 ;; Wait for any float exceptions.
320 #!+x86 (float-wait))))
324 (defmacro handler-case (form &rest cases)
326 { (type ([var]) body) }* )
327 Execute FORM in a context with handlers established for the condition
328 types. A peculiar property allows type to be :no-error. If such a clause
329 occurs, and form returns normally, all its values are passed to this clause
330 as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
333 ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH
334 ;; operations, which seems like an ugly way to handle lexical
335 ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch
336 ;; (included below this form, but #+NIL'ed out) to switch over to
337 ;; RETURN-FROM, which seems like basically a better idea.
338 ;; Unfortunately when using his patch, this reasonable code
340 ;; (IF (NOT (IGNORE-ERRORS
341 ;; (MAKE-PATHNAME :HOST "FOO"
345 ;; (ERROR "NOTUNLESSNOT")))
346 ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK"
347 ;; instead). I think this may not be a bug in MNA's patch, but
348 ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM)
349 ;; but whatever the reason. (I noticed this problem in
350 ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
351 ;; The problem also occurs at least in sbcl-0.6.12.59 and
352 ;; sbcl-0.6.13.) -- WHN
353 (let ((no-error-clause (assoc ':no-error cases)))
355 (let ((normal-return (make-symbol "normal-return"))
356 (error-return (make-symbol "error-return")))
357 `(block ,error-return
358 (multiple-value-call #'(lambda ,@(cdr no-error-clause))
359 (block ,normal-return
360 (return-from ,error-return
361 (handler-case (return-from ,normal-return ,form)
362 ,@(remove no-error-clause cases)))))))
367 (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
369 `(let ((,outer-tag (cons nil nil))
370 (,inner-tag (cons nil nil))
372 ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
378 ,(mapcar #'(lambda (annotated-case)
379 `(,(cadr annotated-case)
381 ,(if (caddr annotated-case)
383 '(declare (ignore temp)))
385 ',(car annotated-case))
386 (throw ,inner-tag nil))))
390 ,@(mapcar #'(lambda (annotated-case)
391 (let ((body (cdddr annotated-case))
392 (varp (caddr annotated-case)))
393 `(,(car annotated-case)
395 `((let ((,(car varp) ,var))
398 annotated-cases)))))))
399 #+nil ; MNA's patched version -- see FIXME above
400 (let ((no-error-clause (assoc ':no-error cases)))
402 (let ((normal-return (make-symbol "normal-return"))
403 (error-return (make-symbol "error-return")))
404 `(block ,error-return
405 (multiple-value-call (lambda ,@(cdr no-error-clause))
406 (block ,normal-return
407 (return-from ,error-return
408 (handler-case (return-from ,normal-return ,form)
409 ,@(remove no-error-clause cases)))))))
412 (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
416 (declare (ignorable ,var))
419 ,(mapcar (lambda (annotated-case)
420 (list (cadr annotated-case)
422 ,(if (caddr annotated-case)
424 '(declare (ignore temp)))
425 (go ,(car annotated-case)))))
429 #!+x86 (multiple-value-prog1 ,form
430 ;; Need to catch FP errors here!
433 (lambda (annotated-case)
434 (list (car annotated-case)
435 (let ((body (cdddr annotated-case)))
438 ,(cond ((caddr annotated-case)
439 `(let ((,(caaddr annotated-case)
445 `(progn ,@body)))))))
446 annotated-cases))))))))
448 ;;;; helper functions for restartable error handling which couldn't be
449 ;;;; defined 'til now 'cause they use the RESTART-CASE macro
451 (defun assert-error (assertion places datum &rest arguments)
452 (let ((cond (if datum
453 (coerce-to-condition datum
457 (make-condition 'simple-error
458 :format-control "The assertion ~S failed."
459 :format-arguments (list assertion)))))
463 :report (lambda (stream)
464 (format stream "Retry assertion")
467 " with new value~P for ~{~S~^, ~}."
470 (format stream ".")))
473 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
474 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
475 ;;; and by CHECK-TYPE.
476 (defun read-evaluated-form ()
477 (format *query-io* "~&Type a form to be evaluated:~%")
478 (list (eval (read *query-io*))))
480 (defun check-type-error (place place-value type type-string)
481 (let ((cond (if type-string
482 (make-condition 'simple-type-error
486 "The value of ~S is ~S, which is not ~A."
487 :format-arguments (list place
490 (make-condition 'simple-type-error
494 "The value of ~S is ~S, which is not of type ~S."
495 :format-arguments (list place
498 (restart-case (error cond)
500 :report (lambda (stream)
501 (format stream "Supply a new value for ~S." place))
502 :interactive read-evaluated-form
505 (defun case-body-error (name keyform keyform-value expected-type keys)
510 :expected-type expected-type
513 :report (lambda (stream)
514 (format stream "Supply a new value for ~S." keyform))
515 :interactive read-evaluated-form