← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/clcs_restart.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/clcs_restart.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(IN-PACKAGE "CONDITIONS")
 
4
 
 
5
;;; Unique Ids
 
6
 
 
7
(DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE))
 
8
(DEFVAR *UNIQUE-ID-COUNT* -1)
 
9
 
 
10
(DEFUN UNIQUE-ID (OBJ)
 
11
  "Generates a unique integer ID for its argument."
 
12
  (OR (GETHASH OBJ *UNIQUE-ID-TABLE*)
 
13
      (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*))))
 
14
 
 
15
;;; Miscellaneous Utilities
 
16
 
 
17
(EVAL-WHEN (EVAL COMPILE LOAD)
 
18
 
 
19
(DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS)
 
20
  (DO ((L LIST (CDDR L))
 
21
       (K '() (LIST* (CADR L) (CAR L) K)))
 
22
      ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS)))
 
23
       (VALUES (NREVERSE K) L))))
 
24
 
 
25
(DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS)
 
26
  (LET ((TEMP (MEMBER '&REST NAMES)))
 
27
    (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP))
 
28
    (LET ((KEY-VARS (LDIFF NAMES TEMP))
 
29
          (KEY-VAR (OR KEYWORDS-VAR (GENSYM)))
 
30
          (REST-VAR (CADR TEMP)))
 
31
      (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD")))
 
32
                              KEY-VARS)))
 
33
        `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR)
 
34
             (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS)
 
35
           (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD)))
 
36
                                 KEY-VARS KEYWORDS)
 
37
             ,@FORMS))))))
 
38
 
 
39
);NEHW-LAVE
 
40
 
 
41
;;; Restarts
 
42
 
 
43
(DEFVAR *RESTART-CLUSTERS* '())
 
44
;;;  An ALIST (condition . restarts) which records the restarts currently
 
45
;;; associated with Condition.
 
46
;;;
 
47
(defvar *condition-restarts* ())
 
48
 
 
49
 
 
50
(DEFUN COMPUTE-RESTARTS (&optional condition)
 
51
;  #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts))
 
52
;  #-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)
 
86
  (DECLARE (IGNORE DEPTH))
 
87
  (IF *PRINT-ESCAPE*
 
88
      (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART))
 
89
      (RESTART-REPORT RESTART STREAM)))
 
90
 
 
91
(DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT))
 
92
  NAME
 
93
  FUNCTION
 
94
  REPORT-FUNCTION
 
95
  INTERACTIVE-FUNCTION
 
96
  (test-function #'(lambda (cond) (declare (ignore cond)) t)))
 
97
 
 
98
#+kcl
 
99
(progn
 
100
(defvar *kcl-top-restarts* nil)
 
101
 
 
102
(defun make-kcl-top-restart (quit-tag)
 
103
  ;; 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))
 
107
                :report-function 
 
108
                #'(lambda (stream) 
 
109
                    (let ((b-l (if (eq quit-tag si::*quit-tag*)
 
110
                                   si::*break-level*
 
111
                                   (car (or (find quit-tag si::*quit-tags*
 
112
                                                  :key #'cdr)
 
113
                                            '(:not-found))))))
 
114
                      (cond ((eq b-l :not-found)
 
115
                             (format stream "Return to ? level."))
 
116
                            ((null b-l)
 
117
                             (format stream "Return to top level."))
 
118
                            (t
 
119
                             (format stream "Return to break level ~D."
 
120
                                     (length b-l))))))
 
121
                :interactive-function nil))
 
122
 
 
123
(defun find-kcl-top-restart (quit-tag)
 
124
  (cdr (or (assoc quit-tag *kcl-top-restarts*)
 
125
           (car (push (cons quit-tag (make-kcl-top-restart quit-tag))
 
126
                      *kcl-top-restarts*)))))
 
127
 
 
128
(defun kcl-top-restarts ()
 
129
  (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e))))
 
130
                           si::*quit-tags*))
 
131
         (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags))
 
132
         (restarts (mapcar #'find-kcl-top-restart tags)))
 
133
    (setq *kcl-top-restarts* (mapcar #'cons tags restarts))
 
134
    restarts))
 
135
)  
 
136
 
 
137
(DEFUN RESTART-REPORT (RESTART STREAM)
 
138
  (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART)
 
139
               (LET ((NAME (RESTART-NAME RESTART)))
 
140
                 #'(LAMBDA (STREAM)
 
141
                     (IF NAME (FORMAT STREAM "~S" NAME)
 
142
                              (FORMAT STREAM "~S" RESTART)))))
 
143
           STREAM))
 
144
 
 
145
(DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS)
 
146
  `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING)
 
147
                                                       `(MAKE-RESTART
 
148
                                                          :NAME     ',(CAR BINDING)
 
149
                                                          :FUNCTION ,(CADR BINDING)
 
150
                                                          ,@(CDDR BINDING)))
 
151
                                                   BINDINGS))
 
152
                                   *RESTART-CLUSTERS*)))
 
153
     ,@FORMS))
 
154
 
 
155
(DEFUN FIND-RESTART (NAME &optional condition)
 
156
  (let ((rl (compute-restarts condition)))
 
157
    (dolist (restart rl)
 
158
      (when (or (eq restart name) (eq (restart-name restart) name))
 
159
        (return-from find-restart restart)))))
 
160
;  (declare (ignore condition))
 
161
;  (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*)
 
162
;    (DOLIST (RESTART RESTART-CLUSTER)
 
163
;      (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))
 
164
;       (RETURN-FROM FIND-RESTART RESTART))))
 
165
;  #+kcl 
 
166
;  (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)
 
172
  (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
 
173
                          (specific-ERROR :control-error "Restart ~S is not active." RESTART))))
 
174
       (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES)))
 
175
 
 
176
(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART)
 
177
  (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
 
178
                          (ERROR "Restart ~S is not active." RESTART))))
 
179
    (APPLY (RESTART-FUNCTION REAL-RESTART)
 
180
           (LET ((INTERACTIVE-FUNCTION
 
181
                   (RESTART-INTERACTIVE-FUNCTION REAL-RESTART)))
 
182
             (IF INTERACTIVE-FUNCTION
 
183
                 (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)
 
236
  (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE TEST)
 
237
           (LET ((RESULT '()))
 
238
             (WHEN REPORT
 
239
               (SETQ RESULT (LIST* (IF (STRINGP REPORT)
 
240
                                       `#'(LAMBDA (STREAM)
 
241
                                            (WRITE-STRING ,REPORT STREAM))
 
242
                                       `#',REPORT)
 
243
                                   :REPORT-FUNCTION
 
244
                                   RESULT)))
 
245
             (WHEN INTERACTIVE
 
246
               (SETQ RESULT (LIST* `#',INTERACTIVE
 
247
                                   :INTERACTIVE-FUNCTION
 
248
                                   RESULT)))
 
249
             (when test
 
250
               (setq result (list* `#',test
 
251
                                   :test-function
 
252
                                   result)))
 
253
             (NREVERSE RESULT))))
 
254
    (LET ((BLOCK-TAG (GENSYM))
 
255
          (TEMP-VAR  (GENSYM))
 
256
          (DATA
 
257
            (MAPCAR #'(LAMBDA (CLAUSE)
 
258
                        (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE TEST &REST FORMS)
 
259
                                             (CDDR CLAUSE))
 
260
                          (LIST (CAR CLAUSE)                       ;Name=0
 
261
                                (GENSYM)                           ;Tag=1
 
262
                                (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2
 
263
                                                    :INTERACTIVE INTERACTIVE
 
264
                                                    :TEST TEST)
 
265
                                (CADR CLAUSE)                      ;BVL=3
 
266
                                FORMS)))                           ;Body=4
 
267
                    CLAUSES)))
 
268
      `(BLOCK ,BLOCK-TAG
 
269
         (LET ((,TEMP-VAR NIL))
 
270
           (TAGBODY
 
271
             (RESTART-BIND
 
272
               ,(MAPCAR #'(LAMBDA (DATUM)
 
273
                            (LET ((NAME (NTH 0 DATUM))
 
274
                                  (TAG  (NTH 1 DATUM))
 
275
                                  (KEYS (NTH 2 DATUM)))
 
276
                              `(,NAME #'(LAMBDA (&REST TEMP)
 
277
                                          #+LISPM (SETQ TEMP (COPY-LIST TEMP))
 
278
                                          (SETQ ,TEMP-VAR TEMP)
 
279
                                          (GO ,TAG))
 
280
                                ,@KEYS)))
 
281
                        DATA)
 
282
               (RETURN-FROM ,BLOCK-TAG ,(munge-restart-case-expression EXPRESSION data)))
 
283
             ,@(MAPCAN #'(LAMBDA (DATUM)
 
284
                           (LET ((TAG  (NTH 1 DATUM))
 
285
                                 (BVL  (NTH 3 DATUM))
 
286
                                 (BODY (NTH 4 DATUM)))
 
287
                             (LIST TAG
 
288
                                   `(RETURN-FROM ,BLOCK-TAG
 
289
                                      (APPLY #'(LAMBDA ,BVL ,@BODY)
 
290
                                             ,TEMP-VAR)))))
 
291
                       DATA)))))))
 
292
 
 
293
(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING
 
294
                                             &REST FORMAT-ARGUMENTS)
 
295
                               &BODY FORMS)
 
296
  `(RESTART-CASE (PROGN ,@FORMS)
 
297
     (,RESTART-NAME ()
 
298
        :REPORT (LAMBDA (STREAM)
 
299
                  (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS))
 
300
      (VALUES NIL T))))
 
301
 
 
302
;(DEFUN ABORT          (&optional condition)      (INVOKE-RESTART (find-restart 'ABORT condition))
 
303
;                                     (ERROR 'ABORT-FAILURE))
 
304
;(DEFUN CONTINUE       ()      (INVOKE-RESTART 'CONTINUE))
 
305
;(DEFUN MUFFLE-WARNING ()      (INVOKE-RESTART 'MUFFLE-WARNING))
 
306
;(DEFUN STORE-VALUE    (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE))
 
307
;(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.")