Skip to content
Snippets Groups Projects
Commit ebc3317f authored by ram's avatar ram
Browse files

Implemented CONDITION-RESTARTS ANSI cleanup & WITH-CONDITION-RESTARTS macro.

This provides a way to say that restarts are relevant only to a certain
condition.
parent 623e9cd9
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.23 1993/06/24 14:09:41 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.24 1993/07/02 15:06:33 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -32,6 +32,7 @@ ...@@ -32,6 +32,7 @@
;; proposal has been accepted. ;; proposal has been accepted.
*break-on-signals* *debugger-hook* signal handler-case handler-bind *break-on-signals* *debugger-hook* signal handler-case handler-bind
ignore-errors define-condition make-condition with-simple-restart ignore-errors define-condition make-condition with-simple-restart
with-condition-restarts
restart-case restart-bind restart-name restart-name find-restart restart-case restart-bind restart-name restart-name find-restart
compute-restarts invoke-restart invoke-restart-interactively abort compute-restarts invoke-restart invoke-restart-interactively abort
continue muffle-warning store-value use-value invoke-debugger restart continue muffle-warning store-value use-value invoke-debugger restart
...@@ -84,25 +85,49 @@ ...@@ -84,25 +85,49 @@
;;;; Restarts. ;;;; Restarts.
;;; A list of lists of restarts.
;;;
(defvar *restart-clusters* '()) (defvar *restart-clusters* '())
(defun compute-restarts () ;;; An ALIST (condition . restarts) which records the restarts currently
;;; associated with Condition.
;;;
(defvar *condition-restarts* ())
(defun compute-restarts (&optional condition)
"Return a list of all the currently active restarts ordered from most "Return a list of all the currently active restarts ordered from most
recently established to less recently established." recently established to less recently established. If Condition is
(copy-list (apply #'append *restart-clusters*))) specified, then only restarts associated with Condition (or with no
condition) will be returned."
(let ((associated ())
(other ()))
(dolist (alist *condition-restarts*)
(if (eq (car alist) condition)
(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) condition))
(res restart))))
(res))))
(defun restart-print (restart stream depth) (defun restart-print (restart stream depth)
(declare (ignore depth)) (declare (ignore depth))
(if *print-escape* (if *print-escape*
(format stream "#<~S.~X>" (print-unreadable-object (restart stream :type t :identity t))
(type-of restart) (system:%primitive lisp::make-fixnum restart))
(restart-report restart stream))) (restart-report restart stream)))
(defstruct (restart (:print-function restart-print)) (defstruct (restart (:print-function restart-print))
name name
function function
report-function report-function
interactive-function) interactive-function
(test-function #'(lambda (cond) (declare (ignore cond)) t)))
(setf (documentation 'restart-name 'function) (setf (documentation 'restart-name 'function)
"Returns the name of the given restart object.") "Returns the name of the given restart object.")
...@@ -115,6 +140,21 @@ ...@@ -115,6 +140,21 @@
(format stream "~S" restart))))) (format stream "~S" restart)))))
stream)) stream))
(defmacro with-condition-restarts (condition-form restarts-form &body body)
"WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
Evaluates the Forms in a dynamic environment where the restarts in the list
Restarts-Form are associated with the condition returned by Condition-Form.
This allows FIND-RESTART, etc., to recognize restarts that are not related
to the error currently being debugged. See also RESTART-CASE."
(let ((n-cond (gensym)))
`(let ((*condition-restarts*
(cons (let ((,n-cond ,condition-form))
(cons ,n-cond
(append ,restarts-form
(cdr (assoc ,n-cond *condition-restarts*)))))
*condition-restarts*)))
,@body)))
(defmacro restart-bind (bindings &body forms) (defmacro restart-bind (bindings &body forms)
"Executes forms in a dynamic context where the given restart bindings are "Executes forms in a dynamic context where the given restart bindings are
in effect. Users probably want to use RESTART-CASE. When clauses contain in effect. Users probably want to use RESTART-CASE. When clauses contain
...@@ -136,15 +176,16 @@ ...@@ -136,15 +176,16 @@
*restart-clusters*))) *restart-clusters*)))
,@forms)) ,@forms))
(defun find-restart (name) (defun find-restart (name &optional condition)
"Returns the first restart named name. If name is a restart, it is returned "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. if it is currently active. If no such restart is found, nil is returned.
It is an error to supply nil as a name." It is an error to supply nil as a name. If Condition is specified and not
(dolist (restart-cluster *restart-clusters*) NIL, then only restarts associated with that condition (or with no
(dolist (restart restart-cluster) condition) will be returned."
(when (or (eq restart name) (eq (restart-name restart) name)) (find-if #'(lambda (x)
(return-from find-restart restart))))) (or (eq x name)
(eq (restart-name x) name)))
(compute-restarts condition)))
(defun invoke-restart (restart &rest values) (defun invoke-restart (restart &rest values)
"Calls the function associated with the given restart, passing any given "Calls the function associated with the given restart, passing any given
...@@ -174,6 +215,9 @@ ...@@ -174,6 +215,9 @@
'()))))) '())))))
#|
This hack of using catch w/ conses should no longer be necessary...
(defmacro restart-case (expression &body clauses) (defmacro restart-case (expression &body clauses)
"(RESTART-CASE form "(RESTART-CASE form
{(case-name arg-list {keyword value}* body)}*) {(case-name arg-list {keyword value}* body)}*)
...@@ -236,9 +280,38 @@ ...@@ -236,9 +280,38 @@
`(,tag `(,tag
(apply #'(lambda ,bvl ,@body) ,temp-var)))) (apply #'(lambda ,bvl ,@body) ,temp-var))))
data))))))) data)))))))
#| |#
This macro doesn't work in our system due to lossage in closing over tags.
The previous version is uglier, but it sets up unique run-time tags. (eval-when (compile load eval)
;;; 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)))
(if (consp exp)
(let* ((name (car exp))
(args (if (eq name 'cerror) (cddr exp) (cdr exp))))
(if (member name '(signal error cerror warn))
(once-only ((n-cond `(coerce-to-condition
,(first args)
(list ,@(rest args))
',(case name
(warn 'simple-warning)
(signal 'simple-condition)
(t 'simple-error))
',name)))
`(with-condition-restarts
,n-cond
(list ,@(mapcar #'(lambda (da)
`(find-restart ',(nth 0 da)))
data))
,(if (eq name 'cerror)
`(cerror ,(second expression) ,n-cond)
`(,name ,n-cond))))
expression))
expression)))
); eval-when (compile load eval)
(defmacro restart-case (expression &body clauses) (defmacro restart-case (expression &body clauses)
"(RESTART-CASE form "(RESTART-CASE form
...@@ -246,8 +319,10 @@ The previous version is uglier, but it sets up unique run-time tags. ...@@ -246,8 +319,10 @@ The previous version is uglier, but it sets up unique run-time tags.
The form is evaluated in a dynamic context where the clauses have special The form is evaluated in a dynamic context where the clauses have special
meanings as points to which control may be transferred (see INVOKE-RESTART). meanings as points to which control may be transferred (see INVOKE-RESTART).
When clauses contain the same case-name, FIND-RESTART will find the first When clauses contain the same case-name, FIND-RESTART will find the first
such clause." such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
(flet ((transform-keywords (&key report interactive) macroexpands into such) then the signalled condition will be associated with
the new restarts."
(flet ((transform-keywords (&key report interactive test)
(let ((result '())) (let ((result '()))
(when report (when report
(setq result (list* (if (stringp report) (setq result (list* (if (stringp report)
...@@ -260,45 +335,55 @@ The previous version is uglier, but it sets up unique run-time tags. ...@@ -260,45 +335,55 @@ The previous version is uglier, but it sets up unique run-time tags.
(setq result (list* `#',interactive (setq result (list* `#',interactive
:interactive-function :interactive-function
result))) result)))
(when test
(setq result (list* `#',test
:test-function
result)))
(nreverse result)))) (nreverse result))))
(let ((block-tag (gensym)) (let ((block-tag (gensym))
(temp-var (gensym)) (temp-var (gensym))
(data (data
(mapcar #'(lambda (clause) (mapcar #'(lambda (clause)
(with-keyword-pairs ((report interactive &rest forms) (with-keyword-pairs ((report interactive test
(cddr clause)) &rest forms)
(list (car clause) ;name=0 (cddr clause))
(gensym) ;tag=1 (list (car clause) ;name=0
(transform-keywords :report report ;keywords=2 (gensym) ;tag=1
:interactive interactive) (transform-keywords :report report ;keywords=2
(cadr clause) ;bvl=3 :interactive interactive
forms))) ;body=4 :test test)
clauses))) (cadr clause) ;bvl=3
forms))) ;body=4
clauses)))
`(block ,block-tag `(block ,block-tag
(let ((,temp-var nil)) (let ((,temp-var nil))
(tagbody (tagbody
(restart-bind (restart-bind
,(mapcar #'(lambda (datum) ,(mapcar #'(lambda (datum)
(let ((name (nth 0 datum)) (let ((name (nth 0 datum))
(tag (nth 1 datum)) (tag (nth 1 datum))
(keys (nth 2 datum))) (keys (nth 2 datum)))
`(,name #'(lambda (&rest temp) `(,name #'(lambda (&rest temp)
(setq ,temp-var temp) (setq ,temp-var temp)
(go ,tag)) (go ,tag))
,@keys))) ,@keys)))
data) data)
(return-from ,block-tag ,expression)) (return-from ,block-tag
,@(mapcan #'(lambda (datum) ,(munge-restart-case-expression expression data)))
(let ((tag (nth 1 datum)) ,@(mapcan #'(lambda (datum)
(bvl (nth 3 datum)) (let ((tag (nth 1 datum))
(body (nth 4 datum))) (bvl (nth 3 datum))
(list tag (body (nth 4 datum)))
`(return-from ,block-tag (list tag
(apply #'(lambda ,bvl ,@body) `(return-from ,block-tag
,temp-var))))) (apply #'(lambda ,bvl ,@body)
data))))))) ,temp-var)))))
|# data)))))))
;;; If just one body form, then don't use progn. This allows restart-case to
;;; "see" calls to error, etc.
;;;
(defmacro with-simple-restart ((restart-name format-string (defmacro with-simple-restart ((restart-name format-string
&rest format-arguments) &rest format-arguments)
&body forms) &body forms)
...@@ -307,7 +392,7 @@ The previous version is uglier, but it sets up unique run-time tags. ...@@ -307,7 +392,7 @@ The previous version is uglier, but it sets up unique run-time tags.
If restart-name is not invoked, then all values returned by forms are If restart-name is not invoked, then all values returned by forms are
returned. If control is transferred to this restart, it immediately returned. If control is transferred to this restart, it immediately
returns the values nil and t." returns the values nil and t."
`(restart-case (progn ,@forms) `(restart-case ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
(,restart-name () (,restart-name ()
:report (lambda (stream) :report (lambda (stream)
(format stream ,format-string ,@format-arguments)) (format stream ,format-string ,@format-arguments))
...@@ -932,26 +1017,26 @@ The previous version sets up unique run-time tags. ...@@ -932,26 +1017,26 @@ The previous version sets up unique run-time tags.
;;; ABORT signals an error in case there was a restart named abort that did ;;; ABORT signals an error in case there was a restart named abort that did
;;; not tranfer control dynamically. This could happen with RESTART-BIND. ;;; not tranfer control dynamically. This could happen with RESTART-BIND.
;;; ;;;
(defun abort () (defun abort (&optional condition)
"Transfers control to a restart named abort, signalling a control-error if "Transfers control to a restart named abort, signalling a control-error if
none exists." none exists."
(invoke-restart 'abort) (invoke-restart (find-restart 'abort condition))
(error 'abort-failure)) (error 'abort-failure))
(defun muffle-warning () (defun muffle-warning (&optional condition)
"Transfers control to a restart named muffle-warning, signalling a "Transfers control to a restart named muffle-warning, signalling a
control-error if none exists." control-error if none exists."
(invoke-restart 'muffle-warning)) (invoke-restart (find-restart 'muffle-warning condition)))
;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep ;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep
;;; INVOKE-RESTART from signalling a control-error condition. ;;; INVOKE-RESTART from signalling a control-error condition.
;;; ;;;
(defmacro define-nil-returning-restart (name args doc) (defmacro define-nil-returning-restart (name args doc)
`(defun ,name ,args `(defun ,name (,@args &optional condition)
,doc ,doc
(if (find-restart ',name) (invoke-restart ',name ,@args)))) (if (find-restart ',name condition) (invoke-restart ',name ,@args))))
(define-nil-returning-restart continue () (define-nil-returning-restart continue ()
"Transfer control to a restart named continue, returning nil if none exists.") "Transfer control to a restart named continue, returning nil if none exists.")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment