;;; a list of lists of restarts
(defvar *restart-clusters* '())
-;;; An ALIST (condition . restarts) which records the restarts currently
-;;; associated with Condition.
+;;; an ALIST (condition . restarts) which records the restarts currently
+;;; associated with Condition
(defvar *condition-restarts* ())
+(defstruct (restart (:copier nil) (:predicate nil))
+ (name (missing-arg) :type symbol :read-only t)
+ (function (missing-arg) :type function)
+ (report-function nil :type (or null function))
+ (interactive-function nil :type (or null function))
+ (test-function (lambda (cond) (declare (ignore cond)) t) :type function))
+(def!method print-object ((restart restart) stream)
+ (if *print-escape*
+ (print-unreadable-object (restart stream :type t :identity t)
+ (prin1 (restart-name restart) stream))
+ (restart-report restart stream)))
+
(defun compute-restarts (&optional condition)
#!+sb-doc
"Return a list of all the currently active restarts ordered from most
- recently established to less recently established. If Condition is
- specified, then only restarts associated with Condition (or with no
+ recently established to less recently established. If CONDITION is
+ specified, then only restarts associated with CONDITION (or with no
condition) will be returned."
(let ((associated ())
(other ()))
(when (and (or (not condition)
(member restart associated)
(not (member restart other)))
- (funcall (restart-test-function restart) condition))
+ (funcall (restart-test-function restart)
+ condition))
(res restart))))
(res))))
-(defstruct (restart (:copier nil))
- name
- function
- report-function
- interactive-function
- (test-function #'(lambda (cond) (declare (ignore cond)) t)))
-(def!method print-object ((restart restart) stream)
- (if *print-escape*
- (print-unreadable-object (restart stream :type t :identity t))
- (restart-report restart stream)))
-
#!+sb-doc
(setf (fdocumentation 'restart-name 'function)
- "Returns the name of the given restart object.")
+ "Return the name of the given restart object.")
(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)))))
+ (lambda (stream)
+ (if name (format stream "~S" name)
+ (format stream "~S" restart)))))
stream))
(defmacro with-condition-restarts (condition-form restarts-form &body body)
the same restart name, FIND-RESTART will find the first such clause."
`(let ((*restart-clusters*
(cons (list
- ,@(mapcar #'(lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
+ ,@(mapcar (lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
report function: ~S"
- binding))
- `(make-restart
- :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
+ binding))
+ `(make-restart :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
*restart-clusters*)))
,@forms))
(defun find-restart (name &optional condition)
#!+sb-doc
- "Returns the first restart named name. If name is a restart, it is returned
- if it is currently active. If no such restart is found, nil is returned.
- It is an error to supply nil as a name. If Condition is specified and not
- NIL, then only restarts associated with that condition (or with no
+ "Return the first restart named NAME. If NAME names a restart, the restart
+ is returned if it is currently active. If no such restart is found, NIL is
+ returned. It is an error to supply NIL as a name. If CONDITION is specified
+ and not NIL, then only restarts associated with that condition (or with no
condition) will be returned."
- (find-if #'(lambda (x)
- (or (eq x name)
- (eq (restart-name x) name)))
- (compute-restarts condition)))
+ (let ((restarts (compute-restarts condition)))
+ (declare (type list restarts))
+ (find-if (lambda (x)
+ (or (eq x name)
+ (eq (restart-name x) name)))
+ restarts)))
+
+(defun find-restart-or-lose (restart-designator)
+ (let ((real-restart (find-restart restart-designator)))
+ (unless real-restart
+ (error 'simple-control-error
+ :format-control "Restart ~S is not active."
+ :format-arguments (list restart-designator)))
+ real-restart))
(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."
- (let ((real-restart (find-restart restart)))
- (unless real-restart
- (error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart)))
+ (/show "entering INVOKE-RESTART" restart)
+ (let ((real-restart (find-restart-or-lose 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)
+ '())))
+
(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 restart)))
- (unless real-restart
- (error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart)))
- (apply (restart-function real-restart)
- (let ((interactive-function
- (restart-interactive-function real-restart)))
- (if interactive-function
- (funcall interactive-function)
- '())))))
+ (let* ((real-restart (find-restart-or-lose restart))
+ (args (interactive-restart-arguments real-restart)))
+ (apply (restart-function real-restart) args)))
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
;;; appropriate. Gross, but it's what the book seems to say...
-(defun munge-restart-case-expression (expression data)
- (let ((exp (macroexpand expression)))
+(defun munge-restart-case-expression (expression env)
+ (let ((exp (sb!xc:macroexpand expression env)))
(if (consp exp)
(let* ((name (car exp))
(args (if (eq name 'cerror) (cddr exp) (cdr exp))))
',name)))
`(with-condition-restarts
,n-cond
- (list ,@(mapcar (lambda (da)
- `(find-restart ',(nth 0 da)))
- data))
+ (car *restart-clusters*)
,(if (eq name 'cerror)
`(cerror ,(second expression) ,n-cond)
`(,name ,n-cond))))
;;; FIXME: I did a fair amount of rearrangement of this code in order to
;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
-(defmacro restart-case (expression &body clauses)
+(defmacro restart-case (expression &body clauses &environment env)
#!+sb-doc
"(RESTART-CASE form
{(case-name arg-list {keyword value}* body)}*)
:interactive-function
result)))
(when test
- (setq result (list* `#',test
- :test-function
- result)))
+ (setq result (list* `#',test :test-function result)))
(nreverse result)))
(parse-keyword-pairs (list keys)
(do ((l list (cddr l))
(let ((,temp-var nil))
(tagbody
(restart-bind
- ,(mapcar #'(lambda (datum)
- (let ((name (nth 0 datum))
- (tag (nth 1 datum))
- (keys (nth 2 datum)))
- `(,name #'(lambda (&rest temp)
- (setq ,temp-var temp)
- (go ,tag))
- ,@keys)))
+ ,(mapcar (lambda (datum)
+ (let ((name (nth 0 datum))
+ (tag (nth 1 datum))
+ (keys (nth 2 datum)))
+ `(,name #'(lambda (&rest temp)
+ (setq ,temp-var temp)
+ (go ,tag))
+ ,@keys)))
data)
(return-from ,block-tag
- ,(munge-restart-case-expression expression data)))
- ,@(mapcan #'(lambda (datum)
- (let ((tag (nth 1 datum))
- (bvl (nth 3 datum))
- (body (nth 4 datum)))
- (list tag
- `(return-from ,block-tag
- (apply #'(lambda ,bvl ,@body)
- ,temp-var)))))
+ ,(munge-restart-case-expression expression env)))
+ ,@(mapcan (lambda (datum)
+ (let ((tag (nth 1 datum))
+ (bvl (nth 3 datum))
+ (body (nth 4 datum)))
+ (list tag
+ `(return-from ,block-tag
+ (apply (lambda ,bvl ,@body)
+ ,temp-var)))))
data)))))))
(defmacro with-simple-restart ((restart-name format-string
body)
If restart-name is not invoked, then all values returned by forms are
returned. If control is transferred to this restart, it immediately
- returns the values nil and t."
+ returns the values NIL and T."
`(restart-case
;; If there's just one body form, then don't use PROGN. This allows
;; RESTART-CASE to "see" calls to ERROR, etc.
(when member-if
(error "ill-formed handler binding: ~S" (first member-if))))
`(let ((*handler-clusters*
- (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
+ (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
bindings))
*handler-clusters*)))
(multiple-value-prog1
"(HANDLER-CASE form
{ (type ([var]) body) }* )
Execute FORM in a context with handlers established for the condition
- types. A peculiar property allows type to be :no-error. If such a clause
+ types. A peculiar property allows type to be :NO-ERROR. If such a clause
occurs, and form returns normally, all its values are passed to this clause
as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
var specification."
- ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH
- ;; operations, which seems like an ugly way to handle lexical
- ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch
- ;; (included below this form, but #+NIL'ed out) to switch over to
- ;; RETURN-FROM, which seems like basically a better idea.
- ;; Unfortunately when using his patch, this reasonable code
- ;; (DEFUN FOO1I ()
- ;; (IF (NOT (IGNORE-ERRORS
- ;; (MAKE-PATHNAME :HOST "FOO"
- ;; :DIRECTORY "!BLA"
- ;; :NAME "BAR")))
- ;; (PRINT "OK")
- ;; (ERROR "NOTUNLESSNOT")))
- ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK"
- ;; instead). I think this may not be a bug in MNA's patch, but
- ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM)
- ;; but whatever the reason. (I noticed this problem in
- ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
- ;; The problem also occurs at least in sbcl-0.6.12.59 and
- ;; sbcl-0.6.13.) -- WHN
- (let ((no-error-clause (assoc ':no-error cases)))
- (if no-error-clause
- (let ((normal-return (make-symbol "normal-return"))
- (error-return (make-symbol "error-return")))
- `(block ,error-return
- (multiple-value-call #'(lambda ,@(cdr no-error-clause))
- (block ,normal-return
- (return-from ,error-return
- (handler-case (return-from ,normal-return ,form)
- ,@(remove no-error-clause cases)))))))
- (let ((var (gensym))
- (outer-tag (gensym))
- (inner-tag (gensym))
- (tag-var (gensym))
- (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
- cases)))
- `(let ((,outer-tag (cons nil nil))
- (,inner-tag (cons nil nil))
- ,var ,tag-var)
- ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
- ,var ;ignoreable
- (catch ,outer-tag
- (catch ,inner-tag
- (throw ,outer-tag
- (handler-bind
- ,(mapcar #'(lambda (annotated-case)
- `(,(cadr annotated-case)
- #'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (setf ,tag-var
- ',(car annotated-case))
- (throw ,inner-tag nil))))
- annotated-cases)
- ,form)))
- (case ,tag-var
- ,@(mapcar #'(lambda (annotated-case)
- (let ((body (cdddr annotated-case))
- (varp (caddr annotated-case)))
- `(,(car annotated-case)
- ,@(if varp
- `((let ((,(car varp) ,var))
- ,@body))
- body))))
- annotated-cases)))))))
- #+nil ; MNA's patched version -- see FIXME above
+ ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND
+ ;; and names for the subexpressions would make it easier to
+ ;; understand the code below.
(let ((no-error-clause (assoc ':no-error cases)))
(if no-error-clause
(let ((normal-return (make-symbol "normal-return"))
projects / sbcl.git / blobdiff