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

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

CONTINUE, STORE-VALUE, USE-VALUE: return NIL if no such restart.

File size: 9.1 KB
Line 
1;;; restart.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: restart.lisp,v 1.12 2003-12-19 01:36:31 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 GCL.
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 ((res ()))
54;;     (dolist (restart-cluster *restart-clusters*)
55;;       (dolist (restart restart-cluster)
56;;         (push restart res)))
57;;     (nreverse res)))
58  (let ((associated ())
59  (other ()))
60    (dolist (alist *condition-restarts*)
61      (if (eq (car alist) condition)
62    (setq associated (cdr alist))
63    (setq other (append (cdr alist) other))))
64;;     (collect ((res))
65    (let ((res ()))
66      (dolist (restart-cluster *restart-clusters*)
67        (dolist (restart restart-cluster)
68          (when (and (or (not condition)
69                         (member restart associated)
70                         (not (member restart other)))
71                     (funcall (restart-test-function restart) condition))
72;;             (res restart))))
73            (push restart res))))
74;;              (res))))
75      (nreverse res))))
76
77(defun restart-report (restart stream)
78  (funcall (or (restart-report-function restart)
79         (let ((name (restart-name restart)))
80     (lambda (stream)
81       (if name (format stream "~S" name)
82           (format stream "~S" restart)))))
83     stream))
84
85(defun find-restart (name &optional condition)
86  (let ((restarts (compute-restarts condition)))
87    (dolist (restart restarts)
88      (when (or (eq restart name) (eq (restart-name restart) name))
89        (return-from find-restart restart)))))
90
91(defun invoke-restart (restart &rest values)
92  (let ((real-restart (or (find-restart restart)
93                          (error 'control-error
94                                 :format-control "Restart ~s is not active."
95                                 :format-arguments (list restart)))))
96    (apply (restart-function real-restart) values)))
97
98(defun parse-keyword-pairs (list keys)
99  (do ((l list (cddr l))
100       (k '() (list* (cadr l) (car l) k)))
101      ((or (null l) (not (member (car l) keys)))
102       (values (nreverse k) l))))
103
104(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
105  (let ((temp (member '&rest names)))
106    (unless (= (length temp) 2)
107      (error "&REST keyword is ~:[missing~;misplaced~]." temp))
108    (let ((key-vars (ldiff names temp))
109          (key-var (or keywords-var (gensym)))
110          (rest-var (cadr temp)))
111      (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD")))
112                              key-vars)))
113        `(multiple-value-bind (,key-var ,rest-var)
114           (parse-keyword-pairs ,expression ',keywords)
115           (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
116                         key-vars keywords)
117             ,@forms))))))
118
119(defun transform-keywords (&key report interactive test)
120  (let ((result ()))
121    (when report
122      (setf result (list* (if (stringp report)
123                              `#'(lambda (stream)
124                                  (write-string ,report stream))
125                              `#',report)
126                          :report-function
127                          result)))
128    (when interactive
129      (setf result (list* `#',interactive
130                          :interactive-function
131                          result)))
132    (when test
133      (setf result (list* `#',test :test-function result)))
134    (nreverse result)))
135
136(defmacro restart-case (expression &body clauses)
137  (let ((block-tag (gensym))
138        (temp-var (gensym))
139        (data
140         (mapcar #'(lambda (clause)
141                    (with-keyword-pairs ((report interactive test
142                                                 &rest forms)
143                                         (cddr clause))
144                      (list (car clause)
145                            (gensym)
146                            (transform-keywords :report report
147                                                :interactive interactive
148                                                :test test)
149                            (cadr clause)
150                            forms)))
151                 clauses)))
152    `(block ,block-tag
153            (let ((,temp-var nil))
154              (tagbody
155               (restart-bind
156                ,(mapcar #'(lambda (datum)
157                            (let ((name (nth 0 datum))
158                                  (tag  (nth 1 datum))
159                                  (keys (nth 2 datum)))
160                              `(,name #'(lambda (&rest temp)
161                                         (setq ,temp-var temp)
162                                         (go ,tag))
163                                      ,@keys)))
164                         data)
165                (return-from ,block-tag ,expression))
166               ,@(mapcan #'(lambda (datum)
167                            (let ((tag  (nth 1 datum))
168                                  (bvl  (nth 3 datum))
169                                  (body (nth 4 datum)))
170                              (list tag
171                                    `(return-from ,block-tag
172                                                  (apply #'(lambda ,bvl ,@body)
173                                                         ,temp-var)))))
174                         data))))))
175
176(defmacro with-simple-restart ((restart-name format-string
177                                             &rest format-arguments)
178                               &body forms)
179  `(restart-case (progn ,@forms)
180                 (,restart-name ()
181                                :report (lambda (stream)
182                                          (format stream ,format-string ,@format-arguments))
183                                (values nil t))))
184
185;;; WITH-CONDITION-RESTARTS (from CMUCL)
186(defmacro with-condition-restarts (condition-form restarts-form &body body)
187  (let ((n-cond (gensym)))
188    `(let ((*condition-restarts*
189      (cons (let ((,n-cond ,condition-form))
190        (cons ,n-cond
191        (append ,restarts-form
192          (cdr (assoc ,n-cond *condition-restarts*)))))
193      *condition-restarts*)))
194       ,@body)))
195
196(defun abort (&optional condition)
197  (invoke-restart 'abort)
198  (error 'control-error
199         :format-control "ABORT restart failed to transfer control dynamically."))
200
201(defun muffle-warning (&optional condition)
202  (invoke-restart 'muffle-warning))
203
204(defun continue (&optional condition)
205  (let ((restart (find-restart 'continue condition)))
206    (when restart
207      (invoke-restart restart))))
208
209(defun store-value (value &optional condition)
210  (let ((restart (find-restart 'store-value condition)))
211    (when restart
212      (invoke-restart restart value))))
213
214(defun use-value (value &optional condition)
215  (let ((restart (find-restart 'use-value condition)))
216    (when restart
217      (invoke-restart restart value))))
218
219;;; Adapted from SBCL.
220(defun warn (datum &rest arguments)
221  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
222    (require-type condition 'warning)
223    (restart-case (signal condition)
224                  (muffle-warning ()
225                                  :report "Skip warning."
226                                  (return-from warn nil)))
227    (let ((badness (etypecase condition
228                     (style-warning 'style-warning)
229                     (warning 'warning))))
230      (fresh-line *error-output*)
231      (format *error-output* "~S: ~A~%" badness condition)))
232  nil)
233
234(defun cerror (continue-string datum &rest arguments)
235  (with-simple-restart (continue "~A" (apply #'format nil continue-string arguments))
236    (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
237      (with-condition-restarts condition (list (find-restart 'continue))
238        (signal condition)
239        (invoke-debugger condition))))
240  nil)
Note: See TracBrowser for help on using the repository browser.