41 |
;;; Restarts |
;;; Restarts |
42 |
|
|
43 |
(DEFVAR *RESTART-CLUSTERS* '()) |
(DEFVAR *RESTART-CLUSTERS* '()) |
44 |
|
;;; An ALIST (condition . restarts) which records the restarts currently |
45 |
|
;;; associated with Condition. |
46 |
|
;;; |
47 |
|
(defvar *condition-restarts* ()) |
48 |
|
|
49 |
|
|
|
; FIXME add condition support |
|
50 |
(DEFUN COMPUTE-RESTARTS (&optional condition) |
(DEFUN COMPUTE-RESTARTS (&optional condition) |
51 |
#+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts)) |
; #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts)) |
52 |
#-kcl (mapcan #'copy-list *RESTART-CLUSTERS*)) |
; #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*)) |
53 |
|
(let ((associated ()) |
54 |
|
(other ())) |
55 |
|
(dolist (alist *condition-restarts*) |
56 |
|
(if (eq (car alist) condition) |
57 |
|
(setq associated (cdr alist)) |
58 |
|
(setq other (append (cdr alist) other)))) |
59 |
|
(let ((res '())) |
60 |
|
(dolist (restart-cluster *restart-clusters*) |
61 |
|
(dolist (restart restart-cluster) |
62 |
|
(when (and (or (not condition) |
63 |
|
(member restart associated) |
64 |
|
(not (member restart other))) |
65 |
|
(funcall (restart-test-function restart) condition)) |
66 |
|
(push restart res)))) |
67 |
|
(nconc (nreverse res) (kcl-top-restarts))))) |
68 |
|
; (nreverse res)))) |
69 |
|
|
70 |
|
(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)) |
79 |
|
(cons ,n-cond |
80 |
|
(append ,restarts-form |
81 |
|
(cdr (assoc ,n-cond *condition-restarts*))))) |
82 |
|
*condition-restarts*))) |
83 |
|
,@body))) |
84 |
|
|
85 |
(DEFUN RESTART-PRINT (RESTART STREAM DEPTH) |
(DEFUN RESTART-PRINT (RESTART STREAM DEPTH) |
86 |
(DECLARE (IGNORE DEPTH)) |
(DECLARE (IGNORE DEPTH)) |
92 |
NAME |
NAME |
93 |
FUNCTION |
FUNCTION |
94 |
REPORT-FUNCTION |
REPORT-FUNCTION |
95 |
INTERACTIVE-FUNCTION) |
INTERACTIVE-FUNCTION |
96 |
|
(test-function #'(lambda (cond) (declare (ignore cond)) t))) |
97 |
|
|
98 |
#+kcl |
#+kcl |
99 |
(progn |
(progn |
100 |
(defvar *kcl-top-restarts* nil) |
(defvar *kcl-top-restarts* nil) |
101 |
|
|
102 |
(defun make-kcl-top-restart (quit-tag) |
(defun make-kcl-top-restart (quit-tag) |
103 |
(make-restart :name 'abort |
;; FIXME need this restart for :q, but invoke-restarts must signal |
104 |
|
;; a control error if abort called outside a defined restart |
105 |
|
(make-restart :name 'abort1 |
106 |
:function #'(lambda () (throw (car (list quit-tag)) quit-tag)) |
:function #'(lambda () (throw (car (list quit-tag)) quit-tag)) |
107 |
:report-function |
:report-function |
108 |
#'(lambda (stream) |
#'(lambda (stream) |
153 |
,@FORMS)) |
,@FORMS)) |
154 |
|
|
155 |
(DEFUN FIND-RESTART (NAME &optional condition) |
(DEFUN FIND-RESTART (NAME &optional condition) |
156 |
;FIXME add condition support |
(let ((rl (compute-restarts condition))) |
157 |
(declare (ignore condition)) |
(dolist (restart rl) |
158 |
(DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*) |
(when (or (eq restart name) (eq (restart-name restart) name)) |
159 |
(DOLIST (RESTART RESTART-CLUSTER) |
(return-from find-restart restart))))) |
160 |
(WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) |
; (declare (ignore condition)) |
161 |
(RETURN-FROM FIND-RESTART RESTART)))) |
; (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*) |
162 |
#+kcl |
; (DOLIST (RESTART RESTART-CLUSTER) |
163 |
(let ((RESTART-CLUSTER (kcl-top-restarts))) |
; (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) |
164 |
(DOLIST (RESTART RESTART-CLUSTER) |
; (RETURN-FROM FIND-RESTART RESTART)))) |
165 |
(WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) |
; #+kcl |
166 |
(RETURN-FROM FIND-RESTART RESTART))))) |
; (let ((RESTART-CLUSTER (kcl-top-restarts))) |
167 |
|
; (DOLIST (RESTART RESTART-CLUSTER) |
168 |
|
; (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) |
169 |
|
; (RETURN-FROM FIND-RESTART RESTART))))) |
170 |
|
|
171 |
(DEFUN INVOKE-RESTART (RESTART &REST VALUES) |
(DEFUN INVOKE-RESTART (RESTART &REST VALUES) |
172 |
(LET ((REAL-RESTART (OR (FIND-RESTART RESTART) |
(LET ((REAL-RESTART (OR (FIND-RESTART RESTART) |
173 |
(ERROR "Restart ~S is not active." RESTART)))) |
(specific-ERROR :control-error "Restart ~S is not active." RESTART)))) |
174 |
(APPLY (RESTART-FUNCTION REAL-RESTART) VALUES))) |
(APPLY (RESTART-FUNCTION REAL-RESTART) VALUES))) |
175 |
|
|
176 |
(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART) |
(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART) |
177 |
(LET ((REAL-RESTART (OR (FIND-RESTART RESTART) |
(LET ((REAL-RESTART (OR (FIND-RESTART RESTART) |
183 |
(FUNCALL INTERACTIVE-FUNCTION) |
(FUNCALL INTERACTIVE-FUNCTION) |
184 |
'()))))) |
'()))))) |
185 |
|
|
186 |
|
(eval-when (compile load eval) |
187 |
|
;;; Wrap the restart-case expression in a with-condition-restarts if |
188 |
|
;;; appropriate. Gross, but it's what the book seems to say... |
189 |
|
;;; |
190 |
|
(defmacro once-only (specs &body body) |
191 |
|
"Once-Only ({(Var Value-Expression)}*) Form* |
192 |
|
Create a Let* which evaluates each Value-Expression, binding a temporary |
193 |
|
variable to the result, and wrapping the Let* around the result of the |
194 |
|
evaluation of Body. Within the body, each Var is bound to the corresponding |
195 |
|
temporary variable." |
196 |
|
(LABELS ((FROB (SPECS BODY) |
197 |
|
(IF (NULL SPECS) |
198 |
|
`(PROGN ,@BODY) |
199 |
|
(LET ((SPEC (FIRST SPECS))) |
200 |
|
(WHEN (/= (LENGTH SPEC) 2) |
201 |
|
(ERROR "Malformed Once-Only binding spec: ~S." SPEC)) |
202 |
|
(LET ((NAME (FIRST SPEC)) (EXP-TEMP (GENSYM))) |
203 |
|
`(LET ((,EXP-TEMP ,(SECOND SPEC)) (,NAME (GENSYM "OO-"))) |
204 |
|
`(LET ((,,NAME ,,EXP-TEMP)) |
205 |
|
,,(FROB (REST SPECS) BODY)))))))) |
206 |
|
(FROB SPECS BODY))) |
207 |
|
|
208 |
|
(defun munge-restart-case-expression (expression data) |
209 |
|
(let ((exp (macroexpand expression))) |
210 |
|
(if (consp exp) |
211 |
|
(let* ((name (car exp)) |
212 |
|
(args (if (eq name 'cerror) (cddr exp) (cdr exp)))) |
213 |
|
(if (member name '(signal error cerror warn)) |
214 |
|
(once-only ((n-cond `(coerce-to-condition |
215 |
|
,(first args) |
216 |
|
(list ,@(rest args)) |
217 |
|
',(case name |
218 |
|
(warn 'simple-warning) |
219 |
|
(signal 'simple-condition) |
220 |
|
(t 'simple-error)) |
221 |
|
',name))) |
222 |
|
`(with-condition-restarts |
223 |
|
,n-cond |
224 |
|
(list ,@(mapcar #'(lambda (da) |
225 |
|
`(find-restart ',(nth 0 da))) |
226 |
|
data)) |
227 |
|
,(if (eq name 'cerror) |
228 |
|
`(cerror ,(second expression) ,n-cond) |
229 |
|
`(,name ,n-cond)))) |
230 |
|
expression)) |
231 |
|
expression))) |
232 |
|
|
233 |
|
) |
234 |
|
|
235 |
(DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES) |
(DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES) |
236 |
(FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE) |
(FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE TEST) |
237 |
(LET ((RESULT '())) |
(LET ((RESULT '())) |
238 |
(WHEN REPORT |
(WHEN REPORT |
239 |
(SETQ RESULT (LIST* (IF (STRINGP REPORT) |
(SETQ RESULT (LIST* (IF (STRINGP REPORT) |
246 |
(SETQ RESULT (LIST* `#',INTERACTIVE |
(SETQ RESULT (LIST* `#',INTERACTIVE |
247 |
:INTERACTIVE-FUNCTION |
:INTERACTIVE-FUNCTION |
248 |
RESULT))) |
RESULT))) |
249 |
|
(when test |
250 |
|
(setq result (list* `#',test |
251 |
|
:test-function |
252 |
|
result))) |
253 |
(NREVERSE RESULT)))) |
(NREVERSE RESULT)))) |
254 |
(LET ((BLOCK-TAG (GENSYM)) |
(LET ((BLOCK-TAG (GENSYM)) |
255 |
(TEMP-VAR (GENSYM)) |
(TEMP-VAR (GENSYM)) |
256 |
(DATA |
(DATA |
257 |
(MAPCAR #'(LAMBDA (CLAUSE) |
(MAPCAR #'(LAMBDA (CLAUSE) |
258 |
(WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS) |
(WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE TEST &REST FORMS) |
259 |
(CDDR CLAUSE)) |
(CDDR CLAUSE)) |
260 |
(LIST (CAR CLAUSE) ;Name=0 |
(LIST (CAR CLAUSE) ;Name=0 |
261 |
(GENSYM) ;Tag=1 |
(GENSYM) ;Tag=1 |
262 |
(TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2 |
(TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2 |
263 |
:INTERACTIVE INTERACTIVE) |
:INTERACTIVE INTERACTIVE |
264 |
|
:TEST TEST) |
265 |
(CADR CLAUSE) ;BVL=3 |
(CADR CLAUSE) ;BVL=3 |
266 |
FORMS))) ;Body=4 |
FORMS))) ;Body=4 |
267 |
CLAUSES))) |
CLAUSES))) |
279 |
(GO ,TAG)) |
(GO ,TAG)) |
280 |
,@KEYS))) |
,@KEYS))) |
281 |
DATA) |
DATA) |
282 |
(RETURN-FROM ,BLOCK-TAG ,EXPRESSION)) |
(RETURN-FROM ,BLOCK-TAG ,(munge-restart-case-expression EXPRESSION data))) |
283 |
,@(MAPCAN #'(LAMBDA (DATUM) |
,@(MAPCAN #'(LAMBDA (DATUM) |
284 |
(LET ((TAG (NTH 1 DATUM)) |
(LET ((TAG (NTH 1 DATUM)) |
285 |
(BVL (NTH 3 DATUM)) |
(BVL (NTH 3 DATUM)) |
299 |
(FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS)) |
(FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS)) |
300 |
(VALUES NIL T)))) |
(VALUES NIL T)))) |
301 |
|
|
302 |
(DEFUN ABORT () (INVOKE-RESTART 'ABORT) |
;(DEFUN ABORT (&optional condition) (INVOKE-RESTART (find-restart 'ABORT condition)) |
303 |
(ERROR 'ABORT-FAILURE)) |
; (ERROR 'ABORT-FAILURE)) |
304 |
(DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE)) |
;(DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE)) |
305 |
(DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING)) |
;(DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING)) |
306 |
(DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE)) |
;(DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE)) |
307 |
(DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE)) |
;(DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE)) |
308 |
|
|
309 |
|
;;; ABORT signals an error in case there was a restart named abort that did |
310 |
|
;;; not tranfer control dynamically. This could happen with RESTART-BIND. |
311 |
|
;;; |
312 |
|
(defun abort (&optional condition) |
313 |
|
"Transfers control to a restart named abort, signalling a control-error if |
314 |
|
none exists." |
315 |
|
(invoke-restart (find-restart 'abort condition)) |
316 |
|
(error 'abort-failure)) |
317 |
|
|
318 |
|
|
319 |
|
(defun muffle-warning (&optional condition) |
320 |
|
"Transfers control to a restart named muffle-warning, signalling a |
321 |
|
control-error if none exists." |
322 |
|
(invoke-restart (find-restart 'muffle-warning condition))) |
323 |
|
|
324 |
|
|
325 |
|
;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep |
326 |
|
;;; INVOKE-RESTART from signalling a control-error condition. |
327 |
|
;;; |
328 |
|
(defmacro define-nil-returning-restart (name args doc) |
329 |
|
`(defun ,name (,@args &optional condition) |
330 |
|
,doc |
331 |
|
(if (find-restart ',name condition) (invoke-restart ',name ,@args)))) |
332 |
|
|
333 |
|
(define-nil-returning-restart continue () |
334 |
|
"Transfer control to a restart named continue, returning nil if none exists.") |
335 |
|
|
336 |
|
(define-nil-returning-restart store-value (value) |
337 |
|
"Transfer control and value to a restart named store-value, returning nil if |
338 |
|
none exists.") |
339 |
|
|
340 |
|
(define-nil-returning-restart use-value (value) |
341 |
|
"Transfer control and value to a restart named use-value, returning nil if |
342 |
|
none exists.") |