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

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

Work in progress.

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