(def!method print-object ((restart restart) stream)
(if *print-escape*
(print-unreadable-object (restart stream :type t :identity t)
- (prin1 (restart-name restart) stream))
+ (prin1 (restart-name restart) stream))
(restart-report restart stream)))
(defun compute-restarts (&optional condition)
specified, then only restarts associated with CONDITION (or with no
condition) will be returned."
(let ((associated ())
- (other ()))
+ (other ()))
(dolist (alist *condition-restarts*)
(if (eq (car alist) condition)
- (setq associated (cdr alist))
- (setq other (append (cdr alist) other))))
+ (setq associated (cdr alist))
+ (setq other (append (cdr alist) other))))
(collect ((res))
(dolist (restart-cluster *restart-clusters*)
- (dolist (restart restart-cluster)
- (when (and (or (not condition)
- (member restart associated)
- (not (member restart other)))
- (funcall (restart-test-function restart)
+ (dolist (restart restart-cluster)
+ (when (and (or (not condition)
+ (member restart associated)
+ (not (member restart other)))
+ (funcall (restart-test-function restart)
condition))
- (res restart))))
+ (res restart))))
(res))))
#!+sb-doc
(defun restart-report (restart stream)
(funcall (or (restart-report-function restart)
- (let ((name (restart-name restart)))
- (lambda (stream)
- (if name (format stream "~S" name)
- (format stream "~S" restart)))))
- stream))
+ (let ((name (restart-name restart)))
+ (lambda (stream)
+ (if name (format stream "~S" name)
+ (format stream "~S" restart)))))
+ stream))
(defun find-restart (name &optional condition)
#!+sb-doc
(eq (restart-name x) name)))
restarts)))
-(defun find-restart-or-lose (restart-designator)
- (let ((real-restart (find-restart restart-designator)))
- (unless real-restart
+;;; helper for the various functions which are ANSI-spec'ed to do
+;;; something with a restart or signal CONTROL-ERROR if there is none
+(defun find-restart-or-control-error (identifier &optional condition)
+ (or (find-restart identifier condition)
(error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart-designator)))
- real-restart))
+ :format-control "No restart ~S is active~@[ for ~S~]."
+ :format-arguments (list identifier condition))))
(defun invoke-restart (restart &rest values)
#!+sb-doc
"Calls the function associated with the given restart, passing any given
arguments. If the argument restart is not a restart or a currently active
- non-nil restart name, then a control-error is signalled."
+ non-nil restart name, then a CONTROL-ERROR is signalled."
(/show "entering INVOKE-RESTART" restart)
- (let ((real-restart (find-restart-or-lose restart)))
+ (let ((real-restart (find-restart-or-control-error restart)))
(apply (restart-function real-restart) values)))
(defun interactive-restart-arguments (real-restart)
(let ((interactive-function (restart-interactive-function real-restart)))
(if interactive-function
- (funcall interactive-function)
- '())))
+ (funcall interactive-function)
+ '())))
(defun invoke-restart-interactively (restart)
#!+sb-doc
"Calls the function associated with the given restart, prompting for any
necessary arguments. If the argument restart is not a restart or a
- currently active non-nil restart name, then a control-error is signalled."
- (let* ((real-restart (find-restart-or-lose restart))
- (args (interactive-restart-arguments real-restart)))
+ currently active non-NIL restart name, then a CONTROL-ERROR is signalled."
+ (let* ((real-restart (find-restart-or-control-error restart))
+ (args (interactive-restart-arguments real-restart)))
(apply (restart-function real-restart) args)))
\f
-\f
-
-
-
-;;;; helper functions for restartable error handling which couldn't be
-;;;; defined 'til now 'cause they use the RESTART-CASE macro
-
(defun assert-error (assertion places datum &rest arguments)
(let ((cond (if datum
- (coerce-to-condition datum
- arguments
- 'simple-error
- 'error)
- (make-condition 'simple-error
- :format-control "The assertion ~S failed."
- :format-arguments (list assertion)))))
+ (coerce-to-condition datum
+ arguments
+ 'simple-error
+ 'error)
+ (make-condition 'simple-error
+ :format-control "The assertion ~S failed."
+ :format-arguments (list assertion)))))
(restart-case
- (error cond)
+ (error cond)
(continue ()
- :report (lambda (stream)
- (format stream "Retry assertion")
- (if places
- (format stream
- " with new value~P for ~{~S~^, ~}."
- (length places)
- places)
- (format stream ".")))
- nil))))
+ :report (lambda (stream)
+ (format stream "Retry assertion")
+ (if places
+ (format stream
+ " with new value~P for ~{~S~^, ~}."
+ (length places)
+ places)
+ (format stream ".")))
+ nil))))
;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
(list (eval (read *query-io*))))
(defun check-type-error (place place-value type type-string)
- (let ((cond (if type-string
- (make-condition 'simple-type-error
- :datum place
- :expected-type type
- :format-control
- "The value of ~S is ~S, which is not ~A."
- :format-arguments (list place
- place-value
- type-string))
- (make-condition 'simple-type-error
- :datum place
- :expected-type type
- :format-control
- "The value of ~S is ~S, which is not of type ~S."
- :format-arguments (list place
- place-value
- type)))))
- (restart-case (error cond)
+ (let ((condition
+ (make-condition
+ 'simple-type-error
+ :datum place-value
+ :expected-type type
+ :format-control
+ "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
+ :format-arguments (list place place-value type-string type))))
+ (restart-case (error condition)
(store-value (value)
- :report (lambda (stream)
- (format stream "Supply a new value for ~S." place))
- :interactive read-evaluated-form
- value))))
+ :report (lambda (stream)
+ (format stream "Supply a new value for ~S." place))
+ :interactive read-evaluated-form
+ value))))
(defun case-body-error (name keyform keyform-value expected-type keys)
(restart-case
(error 'case-failure
- :name name
- :datum keyform-value
- :expected-type expected-type
- :possibilities keys)
+ :name name
+ :datum keyform-value
+ :expected-type expected-type
+ :possibilities keys)
(store-value (value)
:report (lambda (stream)
- (format stream "Supply a new value for ~S." keyform))
+ (format stream "Supply a new value for ~S." keyform))
:interactive read-evaluated-form
value)))