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

Last change on this file since 4117 was 4117, checked in by piso, 19 years ago

Initial checkin.

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