/[gcl]/gcl/clcs/clcs_restart.lisp
ViewVC logotype

Diff of /gcl/clcs/clcs_restart.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Wed Feb 26 22:21:34 2003 UTC revision 1.2 by camm, Thu Oct 23 15:12:21 2003 UTC
# Line 41  Line 41 
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))
# Line 57  Line 92 
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)
# Line 115  Line 153 
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)
# Line 142  Line 183 
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)
# Line 156  Line 246 
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)))
# Line 184  Line 279 
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))
# Line 204  Line 299 
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.")

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26