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))))
322 ;;;; HANDLER-CASE and IGNORE-ERRORS
324 (defmacro handler-case (form &rest cases)
327 { (type ([var]) body) }* )
328 Executes form in a context with handlers established for the condition
329 types. A peculiar property allows type to be :no-error. If such a clause
330 occurs, and form returns normally, all its values are passed to this clause
331 as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
333 (let ((no-error-clause (assoc ':no-error cases)))
335 (let ((normal-return (make-symbol "normal-return"))
336 (error-return (make-symbol "error-return")))
337 `(block ,error-return
338 (multiple-value-call #'(lambda ,@(cdr no-error-clause))
339 (block ,normal-return
340 (return-from ,error-return
341 (handler-case (return-from ,normal-return ,form)
342 ,@(remove no-error-clause cases)))))))
347 (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
349 `(let ((,outer-tag (cons nil nil))
350 (,inner-tag (cons nil nil))
352 ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
358 ,(mapcar #'(lambda (annotated-case)
359 `(,(cadr annotated-case)
361 ,(if (caddr annotated-case)
363 '(declare (ignore temp)))
365 ',(car annotated-case))
366 (throw ,inner-tag nil))))
370 ,@(mapcar #'(lambda (annotated-case)
371 (let ((body (cdddr annotated-case))
372 (varp (caddr annotated-case)))
373 `(,(car annotated-case)
375 `((let ((,(car varp) ,var))
378 annotated-cases))))))))
380 (defmacro ignore-errors (&rest forms)
382 "Executes forms after establishing a handler for all error conditions that
383 returns from this form NIL and the condition signalled."
384 `(handler-case (progn ,@forms)
385 (error (condition) (values nil condition))))
387 ;;;; helper functions for restartable error handling which couldn't be defined
388 ;;;; 'til now 'cause they use the RESTART-CASE macro
390 (defun assert-error (assertion places datum &rest arguments)
391 (let ((cond (if datum
392 (coerce-to-condition datum
396 (make-condition 'simple-error
397 :format-control "The assertion ~S failed."
398 :format-arguments (list assertion)))))
402 :report (lambda (stream)
403 (format stream "Retry assertion")
406 " with new value~P for ~{~S~^, ~}."
409 (format stream ".")))
412 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
413 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
414 ;;; and by CHECK-TYPE.
415 (defun read-evaluated-form ()
416 (format *query-io* "~&Type a form to be evaluated:~%")
417 (list (eval (read *query-io*))))
419 (defun check-type-error (place place-value type type-string)
420 (let ((cond (if type-string
421 (make-condition 'simple-type-error
425 "The value of ~S is ~S, which is not ~A."
426 :format-arguments (list place
429 (make-condition 'simple-type-error
433 "The value of ~S is ~S, which is not of type ~S."
434 :format-arguments (list place
437 (restart-case (error cond)
439 :report (lambda (stream)
440 (format stream "Supply a new value for ~S." place))
441 :interactive read-evaluated-form
444 (defun case-body-error (name keyform keyform-value expected-type keys)
449 :expected-type expected-type
452 :report (lambda (stream)
453 (format stream "Supply a new value for ~S." keyform))
454 :interactive read-evaluated-form