source: trunk/j/src/org/armedbear/lisp/restart.lisp @ 9266

Last change on this file since 9266 was 9259, checked in by piso, 16 years ago

Indentation.

File size: 11.3 KB
Line 
1;;; restart.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: restart.lisp,v 1.20 2005-05-25 15:53:16 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from CMUCL/SBCL.
21
22(in-package #:system)
23
24(defun read-evaluated-form ()
25  (fresh-line *query-io*)
26  (%format *query-io* "Enter a form to be evaluated:~%")
27  (list (eval (read *query-io*))))
28
29(defvar *restart-clusters* ())
30
31(defvar *condition-restarts* ())
32
33(defstruct restart
34  name
35  function
36  report-function
37  interactive-function
38  (test-function #'(lambda (c) t)))
39
40(defmacro restart-bind (bindings &body forms)
41  `(let ((*restart-clusters*
42          (cons (list
43                 ,@(mapcar #'(lambda (binding)
44                              `(make-restart
45                                :name ',(car binding)
46                                :function ,(cadr binding)
47                                ,@(cddr binding)))
48                           bindings))
49                *restart-clusters*)))
50     ,@forms))
51
52(defun compute-restarts (&optional condition)
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      (nreverse res))))
68
69(defun restart-report (restart stream)
70  (funcall (or (restart-report-function restart)
71         (let ((name (restart-name restart)))
72     (lambda (stream)
73       (if name (%format stream "~S" name)
74           (%format stream "~S" restart)))))
75     stream))
76
77(defun print-restart (restart stream)
78  (if *print-escape*
79      (print-unreadable-object (restart stream :type t :identity t)
80                               (prin1 (restart-name restart) stream))
81      (restart-report restart stream)))
82
83(defun find-restart (name &optional condition)
84  (let ((restarts (compute-restarts condition)))
85    (dolist (restart restarts)
86      (when (or (eq restart name) (eq (restart-name restart) name))
87        (return-from find-restart restart)))))
88
89(defun find-restart-or-control-error (identifier &optional condition)
90  (or (find-restart identifier condition)
91      (error 'control-error
92       :format-control "Restart ~S is not active."
93       :format-arguments (list identifier))))
94
95(defun invoke-restart (restart &rest values)
96  (let ((real-restart (find-restart-or-control-error restart)))
97    (apply (restart-function real-restart) values)))
98
99;;; INVOKE-RESTART-INTERACTIVELY (from CMUCL)
100(defun %invoke-restart-interactively (restart)
101  (apply (restart-function restart)
102   (let ((interactive-function (restart-interactive-function restart)))
103     (if interactive-function
104         (funcall interactive-function)
105         ()))))
106
107(defun invoke-restart-interactively (restart)
108  (let ((real-restart (or (find-restart restart)
109                          (error 'control-error
110                                 :format-control "Restart ~s is not active."
111                                 :format-arguments (list restart)))))
112    (%invoke-restart-interactively real-restart)))
113
114(defun parse-keyword-pairs (list keys)
115  (do ((l list (cddr l))
116       (k '() (list* (cadr l) (car l) k)))
117      ((or (null l) (not (member (car l) keys)))
118       (values (nreverse k) l))))
119
120(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
121  (let ((temp (member '&rest names)))
122    (unless (= (length temp) 2)
123      (error "&REST keyword is ~:[missing~;misplaced~]." temp))
124    (let ((key-vars (ldiff names temp))
125          (key-var (or keywords-var (gensym)))
126          (rest-var (cadr temp)))
127      (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD")))
128                              key-vars)))
129        `(multiple-value-bind (,key-var ,rest-var)
130           (parse-keyword-pairs ,expression ',keywords)
131           (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
132                         key-vars keywords)
133             ,@forms))))))
134
135(defun transform-keywords (&key report interactive test)
136  (let ((result ()))
137    (when report
138      (setf result (list* (if (stringp report)
139                              `#'(lambda (stream)
140                                  (write-string ,report stream))
141                              `#',report)
142                          :report-function
143                          result)))
144    (when interactive
145      (setf result (list* `#',interactive
146                          :interactive-function
147                          result)))
148    (when test
149      (setf result (list* `#',test :test-function result)))
150    (nreverse result)))
151
152
153;; "If the restartable-form is a list whose car is any of the symbols SIGNAL,
154;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a
155;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the
156;; indicated restarts with the condition to be signaled."
157(defun munge-restart-case-expression (expression)
158  (let ((exp (macroexpand expression)))
159    (if (consp exp)
160  (let* ((name (car exp))
161         (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
162    (if (member name '(SIGNAL ERROR CERROR WARN))
163              (let ((n-cond (gensym)))
164                `(let ((,n-cond (coerce-to-condition ,(first args)
165                                                     (list ,@(rest args))
166                                                     ',(case name
167                                                         (WARN 'simple-warning)
168                                                         (SIGNAL 'simple-condition)
169                                                         (t 'simple-error))
170                                                     ',name)))
171                   (with-condition-restarts
172                     ,n-cond
173                     (car *restart-clusters*)
174                     ,(if (eq name 'cerror)
175                          `(cerror ,(second exp) ,n-cond)
176                          `(,name ,n-cond)))))
177              expression))
178        expression)))
179
180(defmacro restart-case (expression &body clauses)
181  (let ((block-tag (gensym))
182        (temp-var (gensym))
183        (data
184         (mapcar #'(lambda (clause)
185                    (with-keyword-pairs ((report interactive test
186                                                 &rest forms)
187                                         (cddr clause))
188                      (list (car clause)
189                            (gensym)
190                            (transform-keywords :report report
191                                                :interactive interactive
192                                                :test test)
193                            (cadr clause)
194                            forms)))
195                 clauses)))
196    `(block ,block-tag
197            (let ((,temp-var nil))
198              (tagbody
199               (restart-bind
200                ,(mapcar #'(lambda (datum)
201                            (let ((name (nth 0 datum))
202                                  (tag  (nth 1 datum))
203                                  (keys (nth 2 datum)))
204                              `(,name #'(lambda (&rest temp)
205                                         (setq ,temp-var temp)
206                                         (go ,tag))
207                                      ,@keys)))
208                         data)
209                (return-from ,block-tag ,(munge-restart-case-expression expression)))
210               ,@(mapcan #'(lambda (datum)
211                            (let ((tag  (nth 1 datum))
212                                  (bvl  (nth 3 datum))
213                                  (body (nth 4 datum)))
214                              (list tag
215                                    `(return-from ,block-tag
216                                                  (apply #'(lambda ,bvl ,@body)
217                                                         ,temp-var)))))
218                         data))))))
219
220(defmacro with-simple-restart ((restart-name format-string
221                                             &rest format-arguments)
222                               &body forms)
223  `(restart-case (progn ,@forms)
224                 (,restart-name ()
225                                :report (lambda (stream)
226                                          (simple-format stream ,format-string ,@format-arguments))
227                                (values nil t))))
228
229(defmacro with-condition-restarts (condition-form restarts-form &body body)
230  (let ((n-cond (gensym)))
231    `(let ((*condition-restarts*
232      (cons (let ((,n-cond ,condition-form))
233        (cons ,n-cond
234        (append ,restarts-form
235          (cdr (assoc ,n-cond *condition-restarts*)))))
236      *condition-restarts*)))
237       ,@body)))
238
239(defun abort (&optional condition)
240  (invoke-restart (find-restart-or-control-error 'abort condition))
241  (error 'control-error
242         :format-control "ABORT restart failed to transfer control dynamically."))
243
244(defun muffle-warning (&optional condition)
245  (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
246
247(defun continue (&optional condition)
248  (let ((restart (find-restart 'continue condition)))
249    (when restart
250      (invoke-restart restart))))
251
252(defun store-value (value &optional condition)
253  (let ((restart (find-restart 'store-value condition)))
254    (when restart
255      (invoke-restart restart value))))
256
257(defun use-value (value &optional condition)
258  (let ((restart (find-restart 'use-value condition)))
259    (when restart
260      (invoke-restart restart value))))
261
262(defun warn (datum &rest arguments)
263  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
264    (require-type condition 'warning)
265    (restart-case (signal condition)
266      (muffle-warning ()
267        :report "Skip warning."
268        (return-from warn nil)))
269    (let ((badness (etypecase condition
270                     (style-warning 'style-warning)
271                     (warning 'warning))))
272      (fresh-line *error-output*)
273      (simple-format *error-output* "~S: ~A~%" badness condition)))
274  nil)
275
276(defun style-warn (format-control &rest format-arguments)
277  (warn 'style-warning
278        :format-control format-control
279        :format-arguments format-arguments))
280
281(defun cerror (continue-string datum &rest arguments)
282  (with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments))
283    (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
284      (with-condition-restarts condition (list (find-restart 'continue))
285        (signal condition)
286        (invoke-debugger condition))))
287  nil)
Note: See TracBrowser for help on using the repository browser.