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

Last change on this file since 8423 was 8423, checked in by piso, 17 years ago

EXT:STYLE-WARN

File size: 11.2 KB
Line 
1;;; restart.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: restart.lisp,v 1.18 2005-01-31 17:17:30 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 invoke-restart (restart &rest values)
90  (let ((real-restart (or (find-restart restart)
91                          (error 'control-error
92                                 :format-control "Restart ~s is not active."
93                                 :format-arguments (list restart)))))
94    (apply (restart-function real-restart) values)))
95
96;;; INVOKE-RESTART-INTERACTIVELY (from CMUCL)
97(defun %invoke-restart-interactively (restart)
98  (apply (restart-function restart)
99   (let ((interactive-function (restart-interactive-function restart)))
100     (if interactive-function
101         (funcall interactive-function)
102         ()))))
103
104(defun invoke-restart-interactively (restart)
105  (let ((real-restart (or (find-restart restart)
106                          (error 'control-error
107                                 :format-control "Restart ~s is not active."
108                                 :format-arguments (list restart)))))
109    (%invoke-restart-interactively real-restart)))
110
111(defun parse-keyword-pairs (list keys)
112  (do ((l list (cddr l))
113       (k '() (list* (cadr l) (car l) k)))
114      ((or (null l) (not (member (car l) keys)))
115       (values (nreverse k) l))))
116
117(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
118  (let ((temp (member '&rest names)))
119    (unless (= (length temp) 2)
120      (error "&REST keyword is ~:[missing~;misplaced~]." temp))
121    (let ((key-vars (ldiff names temp))
122          (key-var (or keywords-var (gensym)))
123          (rest-var (cadr temp)))
124      (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD")))
125                              key-vars)))
126        `(multiple-value-bind (,key-var ,rest-var)
127           (parse-keyword-pairs ,expression ',keywords)
128           (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
129                         key-vars keywords)
130             ,@forms))))))
131
132(defun transform-keywords (&key report interactive test)
133  (let ((result ()))
134    (when report
135      (setf result (list* (if (stringp report)
136                              `#'(lambda (stream)
137                                  (write-string ,report stream))
138                              `#',report)
139                          :report-function
140                          result)))
141    (when interactive
142      (setf result (list* `#',interactive
143                          :interactive-function
144                          result)))
145    (when test
146      (setf result (list* `#',test :test-function result)))
147    (nreverse result)))
148
149
150;; "If the restartable-form is a list whose car is any of the symbols SIGNAL,
151;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a
152;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the
153;; indicated restarts with the condition to be signaled."
154(defun munge-restart-case-expression (expression)
155  (let ((exp (macroexpand expression)))
156    (if (consp exp)
157  (let* ((name (car exp))
158         (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
159    (if (member name '(SIGNAL ERROR CERROR WARN))
160              (let ((n-cond (gensym)))
161                `(let ((,n-cond (coerce-to-condition ,(first args)
162                                                     (list ,@(rest args))
163                                                     ',(case name
164                                                         (WARN 'simple-warning)
165                                                         (SIGNAL 'simple-condition)
166                                                         (t 'simple-error))
167                                                     ',name)))
168                   (with-condition-restarts
169                     ,n-cond
170                     (car *restart-clusters*)
171                     ,(if (eq name 'cerror)
172                          `(cerror ,(second exp) ,n-cond)
173                          `(,name ,n-cond)))))
174              expression))
175        expression)))
176
177(defmacro restart-case (expression &body clauses)
178  (let ((block-tag (gensym))
179        (temp-var (gensym))
180        (data
181         (mapcar #'(lambda (clause)
182                    (with-keyword-pairs ((report interactive test
183                                                 &rest forms)
184                                         (cddr clause))
185                      (list (car clause)
186                            (gensym)
187                            (transform-keywords :report report
188                                                :interactive interactive
189                                                :test test)
190                            (cadr clause)
191                            forms)))
192                 clauses)))
193    `(block ,block-tag
194            (let ((,temp-var nil))
195              (tagbody
196               (restart-bind
197                ,(mapcar #'(lambda (datum)
198                            (let ((name (nth 0 datum))
199                                  (tag  (nth 1 datum))
200                                  (keys (nth 2 datum)))
201                              `(,name #'(lambda (&rest temp)
202                                         (setq ,temp-var temp)
203                                         (go ,tag))
204                                      ,@keys)))
205                         data)
206                (return-from ,block-tag ,(munge-restart-case-expression expression)))
207               ,@(mapcan #'(lambda (datum)
208                            (let ((tag  (nth 1 datum))
209                                  (bvl  (nth 3 datum))
210                                  (body (nth 4 datum)))
211                              (list tag
212                                    `(return-from ,block-tag
213                                                  (apply #'(lambda ,bvl ,@body)
214                                                         ,temp-var)))))
215                         data))))))
216
217(defmacro with-simple-restart ((restart-name format-string
218                                             &rest format-arguments)
219                               &body forms)
220  `(restart-case (progn ,@forms)
221                 (,restart-name ()
222                                :report (lambda (stream)
223                                          (simple-format stream ,format-string ,@format-arguments))
224                                (values nil t))))
225
226(defmacro with-condition-restarts (condition-form restarts-form &body body)
227  (let ((n-cond (gensym)))
228    `(let ((*condition-restarts*
229      (cons (let ((,n-cond ,condition-form))
230        (cons ,n-cond
231        (append ,restarts-form
232          (cdr (assoc ,n-cond *condition-restarts*)))))
233      *condition-restarts*)))
234       ,@body)))
235
236(defun abort (&optional condition)
237  (invoke-restart 'abort)
238  (error 'control-error
239         :format-control "ABORT restart failed to transfer control dynamically."))
240
241(defun muffle-warning (&optional condition)
242  (invoke-restart 'muffle-warning))
243
244(defun continue (&optional condition)
245  (let ((restart (find-restart 'continue condition)))
246    (when restart
247      (invoke-restart restart))))
248
249(defun store-value (value &optional condition)
250  (let ((restart (find-restart 'store-value condition)))
251    (when restart
252      (invoke-restart restart value))))
253
254(defun use-value (value &optional condition)
255  (let ((restart (find-restart 'use-value condition)))
256    (when restart
257      (invoke-restart restart value))))
258
259(defun warn (datum &rest arguments)
260  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
261    (require-type condition 'warning)
262    (restart-case (signal condition)
263                  (muffle-warning ()
264                                  :report "Skip warning."
265                                  (return-from warn nil)))
266    (let ((badness (etypecase condition
267                     (style-warning 'style-warning)
268                     (warning 'warning))))
269      (fresh-line *error-output*)
270      (simple-format *error-output* "~S: ~A~%" badness condition)))
271  nil)
272
273(defun style-warn (format-control &rest format-arguments)
274  (warn 'style-warning
275        :format-control format-control
276        :format-arguments format-arguments))
277
278(defun cerror (continue-string datum &rest arguments)
279  (with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments))
280    (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
281      (with-condition-restarts condition (list (find-restart 'continue))
282        (signal condition)
283        (invoke-debugger condition))))
284  nil)
Note: See TracBrowser for help on using the repository browser.