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

Last change on this file since 5154 was 5154, checked in by piso, 18 years ago

CERROR

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