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

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

PRINT-RESTART

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