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!CONDITIONS")
20 ;;; a list of lists of restarts
21 (defvar *restart-clusters* '())
23 ;;; An ALIST (condition . restarts) which records the restarts currently
24 ;;; associated with Condition.
25 (defvar *condition-restarts* ())
27 (defun compute-restarts (&optional condition)
29 "Return a list of all the currently active restarts ordered from most
30 recently established to less recently established. If Condition is
31 specified, then only restarts associated with Condition (or with no
32 condition) will be returned."
35 (dolist (alist *condition-restarts*)
36 (if (eq (car alist) condition)
37 (setq associated (cdr alist))
38 (setq other (append (cdr alist) other))))
40 (dolist (restart-cluster *restart-clusters*)
41 (dolist (restart restart-cluster)
42 (when (and (or (not condition)
43 (member restart associated)
44 (not (member restart other)))
45 (funcall (restart-test-function restart) condition))
54 (test-function #'(lambda (cond) (declare (ignore cond)) t)))
55 (def!method print-object ((restart restart) stream)
57 (print-unreadable-object (restart stream :type t :identity t))
58 (restart-report restart stream)))
61 (setf (fdocumentation 'restart-name 'function)
62 "Returns the name of the given restart object.")
64 (defun restart-report (restart stream)
65 (funcall (or (restart-report-function restart)
66 (let ((name (restart-name restart)))
68 (if name (format stream "~S" name)
69 (format stream "~S" restart)))))
72 (defmacro with-condition-restarts (condition-form restarts-form &body body)
74 "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
75 Evaluates the Forms in a dynamic environment where the restarts in the list
76 Restarts-Form are associated with the condition returned by Condition-Form.
77 This allows FIND-RESTART, etc., to recognize restarts that are not related
78 to the error currently being debugged. See also RESTART-CASE."
79 (let ((n-cond (gensym)))
80 `(let ((*condition-restarts*
81 (cons (let ((,n-cond ,condition-form))
83 (append ,restarts-form
84 (cdr (assoc ,n-cond *condition-restarts*)))))
85 *condition-restarts*)))
88 (defmacro restart-bind (bindings &body forms)
90 "Executes forms in a dynamic context where the given restart bindings are
91 in effect. Users probably want to use RESTART-CASE. When clauses contain
92 the same restart name, FIND-RESTART will find the first such clause."
93 `(let ((*restart-clusters*
95 ,@(mapcar #'(lambda (binding)
96 (unless (or (car binding)
97 (member :report-function
100 (warn "Unnamed restart does not have a ~
104 :name ',(car binding)
105 :function ,(cadr binding)
108 *restart-clusters*)))
111 (defun find-restart (name &optional condition)
113 "Returns the first restart named name. If name is a restart, it is returned
114 if it is currently active. If no such restart is found, nil is returned.
115 It is an error to supply nil as a name. If Condition is specified and not
116 NIL, then only restarts associated with that condition (or with no
117 condition) will be returned."
118 (find-if #'(lambda (x)
120 (eq (restart-name x) name)))
121 (compute-restarts condition)))
123 (defun invoke-restart (restart &rest values)
125 "Calls the function associated with the given restart, passing any given
126 arguments. If the argument restart is not a restart or a currently active
127 non-nil restart name, then a control-error is signalled."
128 (let ((real-restart (find-restart restart)))
130 (error 'simple-control-error
131 :format-control "Restart ~S is not active."
132 :format-arguments (list restart)))
133 (apply (restart-function real-restart) values)))
135 (defun invoke-restart-interactively (restart)
137 "Calls the function associated with the given restart, prompting for any
138 necessary arguments. If the argument restart is not a restart or a
139 currently active non-nil restart name, then a control-error is signalled."
140 (let ((real-restart (find-restart restart)))
142 (error 'simple-control-error
143 :format-control "Restart ~S is not active."
144 :format-arguments (list restart)))
145 (apply (restart-function real-restart)
146 (let ((interactive-function
147 (restart-interactive-function real-restart)))
148 (if interactive-function
149 (funcall interactive-function)
152 (eval-when (:compile-toplevel :load-toplevel :execute)
153 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
154 ;;; appropriate. Gross, but it's what the book seems to say...
155 (defun munge-restart-case-expression (expression data)
156 (let ((exp (macroexpand expression)))
158 (let* ((name (car exp))
159 (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
160 (if (member name '(signal error cerror warn))
161 (once-only ((n-cond `(coerce-to-condition
165 (warn 'simple-warning)
166 (signal 'simple-condition)
169 `(with-condition-restarts
171 (list ,@(mapcar #'(lambda (da)
172 `(find-restart ',(nth 0 da)))
174 ,(if (eq name 'cerror)
175 `(cerror ,(second expression) ,n-cond)
181 ;;; FIXME: I did a fair amount of rearrangement of this code in order to
182 ;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
183 (defmacro restart-case (expression &body clauses)
186 {(case-name arg-list {keyword value}* body)}*)
187 The form is evaluated in a dynamic context where the clauses have special
188 meanings as points to which control may be transferred (see INVOKE-RESTART).
189 When clauses contain the same case-name, FIND-RESTART will find the first
190 such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
191 macroexpands into such) then the signalled condition will be associated with
193 (flet ((transform-keywords (&key report interactive test)
196 (setq result (list* (if (stringp report)
198 (write-string ,report stream))
203 (setq result (list* `#',interactive
204 :interactive-function
207 (setq result (list* `#',test
211 (parse-keyword-pairs (list keys)
212 (do ((l list (cddr l))
213 (k '() (list* (cadr l) (car l) k)))
214 ((or (null l) (not (member (car l) keys)))
215 (values (nreverse k) l)))))
216 (let ((block-tag (gensym))
219 (macrolet (;; KLUDGE: This started as an old DEFMACRO
220 ;; WITH-KEYWORD-PAIRS general utility, which was used
221 ;; only in this one place in the code. It was translated
222 ;; literally into this MACROLET in order to avoid some
223 ;; cross-compilation bootstrap problems. It would almost
224 ;; certainly be clearer, and it would certainly be more
225 ;; concise, to do a more idiomatic translation, merging
226 ;; this with the TRANSFORM-KEYWORDS logic above.
228 (with-keyword-pairs ((names expression) &body forms)
229 (let ((temp (member '&rest names)))
230 (unless (= (length temp) 2)
231 (error "&REST keyword is ~:[missing~;misplaced~]."
233 (let* ((key-vars (ldiff names temp))
234 (keywords (mapcar #'keywordicate key-vars))
236 (rest-var (cadr temp)))
237 `(multiple-value-bind (,key-var ,rest-var)
238 (parse-keyword-pairs ,expression ',keywords)
239 (let ,(mapcar (lambda (var keyword)
240 `(,var (getf ,key-var
244 (mapcar (lambda (clause)
245 (with-keyword-pairs ((report interactive test
248 (list (car clause) ;name=0
250 (transform-keywords :report report ;keywords=2
251 :interactive interactive
257 (let ((,temp-var nil))
260 ,(mapcar #'(lambda (datum)
261 (let ((name (nth 0 datum))
263 (keys (nth 2 datum)))
264 `(,name #'(lambda (&rest temp)
265 (setq ,temp-var temp)
269 (return-from ,block-tag
270 ,(munge-restart-case-expression expression data)))
271 ,@(mapcan #'(lambda (datum)
272 (let ((tag (nth 1 datum))
274 (body (nth 4 datum)))
276 `(return-from ,block-tag
277 (apply #'(lambda ,bvl ,@body)
281 (defmacro with-simple-restart ((restart-name format-string
282 &rest format-arguments)
285 "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
287 If restart-name is not invoked, then all values returned by forms are
288 returned. If control is transferred to this restart, it immediately
289 returns the values nil and t."
291 ;; If there's just one body form, then don't use PROGN. This allows
292 ;; RESTART-CASE to "see" calls to ERROR, etc.
293 ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
295 :report (lambda (stream)
296 (format stream ,format-string ,@format-arguments))
301 (defvar *handler-clusters* nil)
303 (defmacro handler-bind (bindings &body forms)
305 "(HANDLER-BIND ( {(type handler)}* ) body)
306 Executes body in a dynamic context where the given handler bindings are
307 in effect. Each handler must take the condition being signalled as an
308 argument. The bindings are searched first to last in the event of a
309 signalled condition."
310 (let ((member-if (member-if (lambda (x)
311 (not (proper-list-of-length-p x 2)))
314 (error "ill-formed handler binding: ~S" (first member-if))))
315 `(let ((*handler-clusters*
316 (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
318 *handler-clusters*)))
319 (multiple-value-prog1
321 ;; Wait for any float exceptions
322 #!+x86 (float-wait))))
324 ;;;; HANDLER-CASE and IGNORE-ERRORS
326 (defmacro handler-case (form &rest cases)
329 { (type ([var]) body) }* )
330 Executes form in a context with handlers established for the condition
331 types. A peculiar property allows type to be :no-error. If such a clause
332 occurs, and form returns normally, all its values are passed to this clause
333 as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
335 (let ((no-error-clause (assoc ':no-error cases)))
337 (let ((normal-return (make-symbol "normal-return"))
338 (error-return (make-symbol "error-return")))
339 `(block ,error-return
340 (multiple-value-call #'(lambda ,@(cdr no-error-clause))
341 (block ,normal-return
342 (return-from ,error-return
343 (handler-case (return-from ,normal-return ,form)
344 ,@(remove no-error-clause cases)))))))
349 (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
351 `(let ((,outer-tag (cons nil nil))
352 (,inner-tag (cons nil nil))
354 ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
360 ,(mapcar #'(lambda (annotated-case)
361 `(,(cadr annotated-case)
363 ,(if (caddr annotated-case)
365 '(declare (ignore temp)))
367 ',(car annotated-case))
368 (throw ,inner-tag nil))))
372 ,@(mapcar #'(lambda (annotated-case)
373 (let ((body (cdddr annotated-case))
374 (varp (caddr annotated-case)))
375 `(,(car annotated-case)
377 `((let ((,(car varp) ,var))
380 annotated-cases))))))))
382 ;;; FIXME: Delete this when the system is stable.
384 This macro doesn't work in our system due to lossage in closing over tags.
385 The previous version sets up unique run-time tags.
387 (defmacro handler-case (form &rest cases)
390 { (type ([var]) body) }* )
391 Executes form in a context with handlers established for the condition
392 types. A peculiar property allows type to be :no-error. If such a clause
393 occurs, and form returns normally, all its values are passed to this clause
394 as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
396 (let ((no-error-clause (assoc ':no-error cases)))
398 (let ((normal-return (make-symbol "normal-return"))
399 (error-return (make-symbol "error-return")))
400 `(block ,error-return
401 (multiple-value-call #'(lambda ,@(cdr no-error-clause))
402 (block ,normal-return
403 (return-from ,error-return
404 (handler-case (return-from ,normal-return ,form)
405 ,@(remove no-error-clause cases)))))))
408 (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
415 ,(mapcar #'(lambda (annotated-case)
416 (list (cadr annotated-case)
418 ,(if (caddr annotated-case)
420 '(declare (ignore temp)))
421 (go ,(car annotated-case)))))
423 (return-from ,tag ,form))
425 #'(lambda (annotated-case)
426 (list (car annotated-case)
427 (let ((body (cdddr annotated-case)))
430 ,(cond ((caddr annotated-case)
431 `(let ((,(caaddr annotated-case)
437 `(progn ,@body)))))))
438 annotated-cases))))))))
441 (defmacro ignore-errors (&rest forms)
443 "Executes forms after establishing a handler for all error conditions that
444 returns from this form NIL and the condition signalled."
445 `(handler-case (progn ,@forms)
446 (error (condition) (values nil condition))))
448 ;;;; helper functions for restartable error handling which couldn't be defined
449 ;;;; 'til now 'cause they use the RESTART-CASE macro
451 (defun assert-error (assertion places datum &rest arguments)
452 (let ((cond (if datum
453 (sb!conditions::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)
507 (error 'sb!conditions::case-failure
510 :expected-type expected-type
513 :report (lambda (stream)
514 (format stream "Supply a new value for ~S." keyform))
515 :interactive read-evaluated-form