source: trunk/abcl/src/org/armedbear/lisp/restart.lisp @ 14207

Last change on this file since 14207 was 11785, checked in by ehuelsmann, 12 years ago

Add ignore declaration on unused argument.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 12.7 KB
Line 
1;;; restart.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: restart.lisp 11785 2009-04-26 06:58:46Z ehuelsmann $
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from CMUCL/SBCL.
33
34(in-package #:system)
35
36(defun read-evaluated-form ()
37  (fresh-line *query-io*)
38  (%format *query-io* "Enter a form to be evaluated:~%")
39  (list (eval (read *query-io*))))
40
41(defvar *restart-clusters* ())
42
43(defvar *condition-restarts* ())
44
45(defstruct restart
46  name
47  function
48  report-function
49  interactive-function
50  (test-function #'(lambda (c) (declare (ignore c)) t)))
51
52(defmacro restart-bind (bindings &body forms)
53  `(let ((*restart-clusters*
54          (cons (list
55                 ,@(mapcar #'(lambda (binding)
56                              `(make-restart
57                                :name ',(car binding)
58                                :function ,(cadr binding)
59                                ,@(cddr binding)))
60                           bindings))
61                *restart-clusters*)))
62     ,@forms))
63
64(defun compute-restarts (&optional condition)
65  (let ((associated ())
66  (other ()))
67    (dolist (alist *condition-restarts*)
68      (if (eq (car alist) condition)
69    (setq associated (cdr alist))
70    (setq other (append (cdr alist) other))))
71    (let ((res ()))
72      (dolist (restart-cluster *restart-clusters*)
73        (dolist (restart restart-cluster)
74          (when (and (or (not condition)
75                         (member restart associated)
76                         (not (member restart other)))
77                     (funcall (restart-test-function restart) condition))
78            (push restart res))))
79      (nreverse res))))
80
81(defun restart-report (restart stream)
82  (funcall (or (restart-report-function restart)
83         (let ((name (restart-name restart)))
84     (lambda (stream)
85       (if name (%format stream "~S" name)
86           (%format stream "~S" restart)))))
87     stream))
88
89(defun print-restart (restart stream)
90  (if *print-escape*
91      (print-unreadable-object (restart stream :type t :identity t)
92                               (prin1 (restart-name restart) stream))
93      (restart-report restart stream)))
94
95(defun find-restart (name &optional condition)
96  (let ((restarts (compute-restarts condition)))
97    (dolist (restart restarts)
98      (when (or (eq restart name) (eq (restart-name restart) name))
99        (return-from find-restart restart)))))
100
101(defun find-restart-or-control-error (identifier &optional condition)
102  (or (find-restart identifier condition)
103      (error 'control-error
104       :format-control "Restart ~S is not active."
105       :format-arguments (list identifier))))
106
107(defun invoke-restart (restart &rest values)
108  (let ((real-restart (find-restart-or-control-error restart)))
109    (apply (restart-function real-restart) values)))
110
111(defun interactive-restart-arguments (real-restart)
112  (let ((interactive-function (restart-interactive-function real-restart)))
113    (if interactive-function
114        (funcall interactive-function)
115        '())))
116
117(defun invoke-restart-interactively (restart)
118  (let* ((real-restart (find-restart-or-control-error restart))
119         (args (interactive-restart-arguments real-restart)))
120    (apply (restart-function real-restart) args)))
121
122
123(defun parse-keyword-pairs (list keys)
124  (do ((l list (cddr l))
125       (k '() (list* (cadr l) (car l) k)))
126      ((or (null l) (not (member (car l) keys)))
127       (values (nreverse k) l))))
128
129(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
130  (let ((temp (member '&rest names)))
131    (unless (= (length temp) 2)
132      (error "&REST keyword is ~:[missing~;misplaced~]." temp))
133    (let ((key-vars (ldiff names temp))
134          (key-var (or keywords-var (gensym)))
135          (rest-var (cadr temp)))
136      (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD")))
137                              key-vars)))
138        `(multiple-value-bind (,key-var ,rest-var)
139           (parse-keyword-pairs ,expression ',keywords)
140           (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
141                         key-vars keywords)
142             ,@forms))))))
143
144(defun transform-keywords (&key report interactive test)
145  (let ((result ()))
146    (when report
147      (setf result (list* (if (stringp report)
148                              `#'(lambda (stream)
149                                  (write-string ,report stream))
150                              `#',report)
151                          :report-function
152                          result)))
153    (when interactive
154      (setf result (list* `#',interactive
155                          :interactive-function
156                          result)))
157    (when test
158      (setf result (list* `#',test :test-function result)))
159    (nreverse result)))
160
161
162;; "If the restartable-form is a list whose car is any of the symbols SIGNAL,
163;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a
164;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the
165;; indicated restarts with the condition to be signaled."
166(defun munge-restart-case-expression (expression env)
167  (let ((exp (macroexpand expression env)))
168    (if (consp exp)
169  (let* ((name (car exp))
170         (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
171    (if (member name '(SIGNAL ERROR CERROR WARN))
172              (let ((n-cond (gensym)))
173                `(let ((,n-cond (coerce-to-condition ,(first args)
174                                                     (list ,@(rest args))
175                                                     ',(case name
176                                                         (WARN 'simple-warning)
177                                                         (SIGNAL 'simple-condition)
178                                                         (t 'simple-error))
179                                                     ',name)))
180                   (with-condition-restarts
181                     ,n-cond
182                     (car *restart-clusters*)
183                     ,(if (eq name 'cerror)
184                          `(cerror ,(second exp) ,n-cond)
185                          `(,name ,n-cond)))))
186              expression))
187        expression)))
188
189(defmacro restart-case (expression &body clauses &environment env)
190  (let ((block-tag (gensym))
191        (temp-var (gensym))
192        (data
193         (mapcar #'(lambda (clause)
194                    (with-keyword-pairs ((report interactive test
195                                                 &rest forms)
196                                         (cddr clause))
197                      (list (car clause)
198                            (gensym)
199                            (transform-keywords :report report
200                                                :interactive interactive
201                                                :test test)
202                            (cadr clause)
203                            forms)))
204                 clauses)))
205    `(block ,block-tag
206            (let ((,temp-var nil))
207              (tagbody
208               (restart-bind
209                ,(mapcar #'(lambda (datum)
210                            (let ((name (nth 0 datum))
211                                  (tag  (nth 1 datum))
212                                  (keys (nth 2 datum)))
213                              `(,name #'(lambda (&rest temp)
214                                         (setq ,temp-var temp)
215                                         (go ,tag))
216                                      ,@keys)))
217                         data)
218                (return-from ,block-tag
219                  ,(munge-restart-case-expression expression env)))
220               ,@(mapcan #'(lambda (datum)
221                            (let ((tag  (nth 1 datum))
222                                  (bvl  (nth 3 datum))
223                                  (body (nth 4 datum)))
224                              (list tag
225                                    `(return-from ,block-tag
226                                                  (apply #'(lambda ,bvl ,@body)
227                                                         ,temp-var)))))
228                         data))))))
229
230(defmacro with-simple-restart ((restart-name format-string
231                                             &rest format-arguments)
232                               &body forms)
233  `(restart-case (progn ,@forms)
234                 (,restart-name ()
235                                :report (lambda (stream)
236                                          (simple-format stream ,format-string ,@format-arguments))
237                                (values nil t))))
238
239(defmacro with-condition-restarts (condition-form restarts-form &body body)
240  (let ((n-cond (gensym)))
241    `(let ((*condition-restarts*
242      (cons (let ((,n-cond ,condition-form))
243        (cons ,n-cond
244        (append ,restarts-form
245          (cdr (assoc ,n-cond *condition-restarts*)))))
246      *condition-restarts*)))
247       ,@body)))
248
249(defun abort (&optional condition)
250  (invoke-restart (find-restart-or-control-error 'abort condition))
251  (error 'control-error
252         :format-control "ABORT restart failed to transfer control dynamically."))
253
254(defun muffle-warning (&optional condition)
255  (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
256
257(defun continue (&optional condition)
258  (let ((restart (find-restart 'continue condition)))
259    (when restart
260      (invoke-restart restart))))
261
262(defun store-value (value &optional condition)
263  (let ((restart (find-restart 'store-value condition)))
264    (when restart
265      (invoke-restart restart value))))
266
267(defun use-value (value &optional condition)
268  (let ((restart (find-restart 'use-value condition)))
269    (when restart
270      (invoke-restart restart value))))
271
272(defun warn (datum &rest arguments)
273  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
274    (require-type condition 'warning)
275    (restart-case (signal condition)
276      (muffle-warning ()
277        :report "Skip warning."
278        (return-from warn nil)))
279    (let ((badness (etypecase condition
280                     (style-warning 'style-warning)
281                     (warning 'warning))))
282      (fresh-line *error-output*)
283      (simple-format *error-output* "~S: ~A~%" badness condition)))
284  nil)
285
286(defun style-warn (format-control &rest format-arguments)
287  (warn 'style-warning
288        :format-control format-control
289        :format-arguments format-arguments))
290
291(defun cerror (continue-string datum &rest arguments)
292  (with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments))
293    (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
294      (with-condition-restarts condition (list (find-restart 'continue))
295        (signal condition)
296        (invoke-debugger condition))))
297  nil)
298
299(defun query-function ()
300  (format *query-io* "~&Enter a form to be evaluated: ")
301  (force-output *query-io*)
302  (multiple-value-list (eval (read *query-io*))))
303
304(defun undefined-function-called (name arguments)
305  (finish-output)
306  (loop
307    (restart-case
308        (error 'undefined-function :name name)
309      (continue ()
310        :report "Try again.")
311      (use-value (value)
312        :report "Specify a function to call instead."
313        :interactive query-function
314        (return-from undefined-function-called
315                     (apply value arguments)))
316      (return-value (&rest values)
317        :report (lambda (stream)
318                  (format stream "Return one or more values from the call to ~S." name))
319        :interactive query-function
320        (return-from undefined-function-called
321                     (values-list values))))
322    (when (fboundp name)
323      (return (apply name arguments)))))
Note: See TracBrowser for help on using the repository browser.