1 | ;;; restart.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: restart.lisp 15563 2022-03-10 07:13:02Z mevenson $ |
---|
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 ((res ())) |
---|
66 | (map-restarts (lambda(restart) (push restart res)) condition t) |
---|
67 | (nreverse res))) |
---|
68 | |
---|
69 | (defun map-restarts (fn condition call-test-p) |
---|
70 | (let ((associated ()) |
---|
71 | (other ())) |
---|
72 | (dolist (alist *condition-restarts*) |
---|
73 | (if (eq (car alist) condition) |
---|
74 | (setq associated (cdr alist)) |
---|
75 | (setq other (append (cdr alist) other)))) |
---|
76 | (dolist (restart-cluster *restart-clusters*) |
---|
77 | (dolist (restart restart-cluster) |
---|
78 | (when (and (or (not condition) |
---|
79 | (member restart associated) |
---|
80 | (not (member restart other))) |
---|
81 | (or (not call-test-p) |
---|
82 | (funcall (restart-test-function restart) condition))) |
---|
83 | (funcall fn restart)))))) |
---|
84 | |
---|
85 | |
---|
86 | (defun restart-report (restart stream) |
---|
87 | (funcall (or (restart-report-function restart) |
---|
88 | (let ((name (restart-name restart))) |
---|
89 | (lambda (stream) |
---|
90 | (if name (%format stream "~S" name) |
---|
91 | (%format stream "~S" restart))))) |
---|
92 | stream)) |
---|
93 | |
---|
94 | (defun print-restart (restart stream) |
---|
95 | (if *print-escape* |
---|
96 | (print-unreadable-object (restart stream :type t :identity t) |
---|
97 | (prin1 (restart-name restart) stream)) |
---|
98 | (restart-report restart stream))) |
---|
99 | |
---|
100 | (defun find-restart (name &optional condition) |
---|
101 | (let ((restarts (compute-restarts condition))) |
---|
102 | (dolist (restart restarts) |
---|
103 | (when (or (eq restart name) (eq (restart-name restart) name)) |
---|
104 | (return-from find-restart restart))))) |
---|
105 | |
---|
106 | (defun find-restart-or-control-error (identifier &optional condition) |
---|
107 | (or (find-restart identifier condition) |
---|
108 | (error 'control-error |
---|
109 | :format-control "Restart ~S is not active." |
---|
110 | :format-arguments (list identifier)))) |
---|
111 | |
---|
112 | (defun invoke-restart (restart &rest values) |
---|
113 | (let ((real-restart |
---|
114 | (if (restart-p restart) |
---|
115 | (catch 'found |
---|
116 | (map-restarts (lambda(r) (when (eq r restart) |
---|
117 | (throw 'found r))) |
---|
118 | nil nil) |
---|
119 | (error 'control-error |
---|
120 | :format-control "Restart ~S is not active." |
---|
121 | :format-arguments (list restart))) |
---|
122 | (find-restart-or-control-error restart)))) |
---|
123 | (apply (restart-function real-restart) values))) |
---|
124 | |
---|
125 | (defun interactive-restart-arguments (real-restart) |
---|
126 | (let ((interactive-function (restart-interactive-function real-restart))) |
---|
127 | (if interactive-function |
---|
128 | (funcall interactive-function) |
---|
129 | '()))) |
---|
130 | |
---|
131 | (defun invoke-restart-interactively (restart) |
---|
132 | (let* ((real-restart |
---|
133 | (if (restart-p restart) |
---|
134 | (catch 'found |
---|
135 | (map-restarts (lambda(r) (when (eq r restart) |
---|
136 | (throw 'found r))) |
---|
137 | nil nil) |
---|
138 | (error 'control-error |
---|
139 | :format-control "Restart ~S is not active." |
---|
140 | :format-arguments (list restart))) |
---|
141 | (find-restart-or-control-error restart))) |
---|
142 | (args (interactive-restart-arguments real-restart)) |
---|
143 | ) |
---|
144 | (apply (restart-function real-restart) args))) |
---|
145 | |
---|
146 | (defun parse-keyword-pairs (list keys) |
---|
147 | (do ((l list (cddr l)) |
---|
148 | (k '() (list* (cadr l) (car l) k))) |
---|
149 | ((or (null l) (not (member (car l) keys))) |
---|
150 | (values (nreverse k) l)))) |
---|
151 | |
---|
152 | (defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms) |
---|
153 | (let ((temp (member '&rest names))) |
---|
154 | (unless (= (length temp) 2) |
---|
155 | (error "&REST keyword is ~:[missing~;misplaced~]." temp)) |
---|
156 | (let ((key-vars (ldiff names temp)) |
---|
157 | (key-var (or keywords-var (gensym))) |
---|
158 | (rest-var (cadr temp))) |
---|
159 | (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD"))) |
---|
160 | key-vars))) |
---|
161 | `(multiple-value-bind (,key-var ,rest-var) |
---|
162 | (parse-keyword-pairs ,expression ',keywords) |
---|
163 | (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword))) |
---|
164 | key-vars keywords) |
---|
165 | ,@forms)))))) |
---|
166 | |
---|
167 | (defun transform-keywords (&key report interactive test) |
---|
168 | (let ((result ())) |
---|
169 | (when report |
---|
170 | (setf result (list* (if (stringp report) |
---|
171 | `#'(lambda (stream) |
---|
172 | (write-string ,report stream)) |
---|
173 | `#',report) |
---|
174 | :report-function |
---|
175 | result))) |
---|
176 | (when interactive |
---|
177 | (setf result (list* `#',interactive |
---|
178 | :interactive-function |
---|
179 | result))) |
---|
180 | (when test |
---|
181 | (setf result (list* `#',test :test-function result))) |
---|
182 | (nreverse result))) |
---|
183 | |
---|
184 | |
---|
185 | ;; "If the restartable-form is a list whose car is any of the symbols SIGNAL, |
---|
186 | ;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a |
---|
187 | ;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the |
---|
188 | ;; indicated restarts with the condition to be signaled." |
---|
189 | (defun munge-restart-case-expression (expression env) |
---|
190 | (let ((exp (macroexpand expression env))) |
---|
191 | (if (consp exp) |
---|
192 | (let* ((name (car exp)) |
---|
193 | (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) |
---|
194 | (if (member name '(SIGNAL ERROR CERROR WARN)) |
---|
195 | (let ((n-cond (gensym))) |
---|
196 | `(let ((,n-cond (coerce-to-condition ,(first args) |
---|
197 | (list ,@(rest args)) |
---|
198 | ',(case name |
---|
199 | (WARN 'simple-warning) |
---|
200 | (SIGNAL 'simple-condition) |
---|
201 | (t 'simple-error)) |
---|
202 | ',name))) |
---|
203 | (with-condition-restarts |
---|
204 | ,n-cond |
---|
205 | (car *restart-clusters*) |
---|
206 | ,(if (eq name 'cerror) |
---|
207 | `(cerror ,(second exp) ,n-cond) |
---|
208 | `(,name ,n-cond))))) |
---|
209 | expression)) |
---|
210 | expression))) |
---|
211 | |
---|
212 | (defmacro restart-case (expression &body clauses &environment env) |
---|
213 | (let ((block-tag (gensym)) |
---|
214 | (temp-var (gensym)) |
---|
215 | (data |
---|
216 | (mapcar #'(lambda (clause) |
---|
217 | (with-keyword-pairs ((report interactive test |
---|
218 | &rest forms) |
---|
219 | (cddr clause)) |
---|
220 | (list (car clause) |
---|
221 | (gensym) |
---|
222 | (transform-keywords :report report |
---|
223 | :interactive interactive |
---|
224 | :test test) |
---|
225 | (cadr clause) |
---|
226 | forms))) |
---|
227 | clauses))) |
---|
228 | `(block ,block-tag |
---|
229 | (let ((,temp-var nil)) |
---|
230 | (tagbody |
---|
231 | (restart-bind |
---|
232 | ,(mapcar #'(lambda (datum) |
---|
233 | (let ((name (nth 0 datum)) |
---|
234 | (tag (nth 1 datum)) |
---|
235 | (keys (nth 2 datum))) |
---|
236 | `(,name #'(lambda (&rest temp) |
---|
237 | (setq ,temp-var temp) |
---|
238 | (go ,tag)) |
---|
239 | ,@keys))) |
---|
240 | data) |
---|
241 | (return-from ,block-tag |
---|
242 | ,(munge-restart-case-expression expression env))) |
---|
243 | ,@(mapcan #'(lambda (datum) |
---|
244 | (let ((tag (nth 1 datum)) |
---|
245 | (bvl (nth 3 datum)) |
---|
246 | (body (nth 4 datum))) |
---|
247 | (list tag |
---|
248 | `(return-from ,block-tag |
---|
249 | (apply #'(lambda ,bvl ,@body) |
---|
250 | ,temp-var))))) |
---|
251 | data)))))) |
---|
252 | |
---|
253 | (defmacro with-simple-restart ((restart-name format-string |
---|
254 | &rest format-arguments) |
---|
255 | &body forms) |
---|
256 | `(restart-case (progn ,@forms) |
---|
257 | (,restart-name () |
---|
258 | :report (lambda (stream) |
---|
259 | (simple-format stream ,format-string ,@format-arguments)) |
---|
260 | (values nil t)))) |
---|
261 | |
---|
262 | (defmacro with-condition-restarts (condition-form restarts-form &body body) |
---|
263 | (let ((n-cond (gensym))) |
---|
264 | `(let ((*condition-restarts* |
---|
265 | (cons (let ((,n-cond ,condition-form)) |
---|
266 | (cons ,n-cond |
---|
267 | (append ,restarts-form |
---|
268 | (cdr (assoc ,n-cond *condition-restarts*))))) |
---|
269 | *condition-restarts*))) |
---|
270 | ,@body))) |
---|
271 | |
---|
272 | (defun abort (&optional condition) |
---|
273 | (invoke-restart (find-restart-or-control-error 'abort condition)) |
---|
274 | (error 'control-error |
---|
275 | :format-control "ABORT restart failed to transfer control dynamically.")) |
---|
276 | |
---|
277 | (defun muffle-warning (&optional condition) |
---|
278 | (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) |
---|
279 | |
---|
280 | (defun continue (&optional condition) |
---|
281 | (let ((restart (find-restart 'continue condition))) |
---|
282 | (when restart |
---|
283 | (invoke-restart restart)))) |
---|
284 | |
---|
285 | (defun store-value (value &optional condition) |
---|
286 | (let ((restart (find-restart 'store-value condition))) |
---|
287 | (when restart |
---|
288 | (invoke-restart restart value)))) |
---|
289 | |
---|
290 | (defun use-value (value &optional condition) |
---|
291 | (let ((restart (find-restart 'use-value condition))) |
---|
292 | (when restart |
---|
293 | (invoke-restart restart value)))) |
---|
294 | |
---|
295 | (defun warn (datum &rest arguments) |
---|
296 | (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn))) |
---|
297 | (require-type condition 'warning) |
---|
298 | (restart-case (signal condition) |
---|
299 | (muffle-warning () |
---|
300 | :report "Skip warning." |
---|
301 | (return-from warn nil))) |
---|
302 | (let ((badness (etypecase condition |
---|
303 | (style-warning 'style-warning) |
---|
304 | (warning 'warning)))) |
---|
305 | (fresh-line *error-output*) |
---|
306 | (simple-format *error-output* "~S: ~A~%" badness condition))) |
---|
307 | nil) |
---|
308 | |
---|
309 | (defun style-warn (format-control &rest format-arguments) |
---|
310 | (warn 'style-warning |
---|
311 | :format-control format-control |
---|
312 | :format-arguments format-arguments)) |
---|
313 | |
---|
314 | (defun cerror (continue-string datum &rest arguments) |
---|
315 | (with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments)) |
---|
316 | (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) |
---|
317 | (with-condition-restarts condition (list (find-restart 'continue)) |
---|
318 | (signal condition) |
---|
319 | (invoke-debugger condition)))) |
---|
320 | nil) |
---|
321 | |
---|
322 | (defun query-function () |
---|
323 | (format *query-io* "~&Enter a form to be evaluated: ") |
---|
324 | (force-output *query-io*) |
---|
325 | (multiple-value-list (eval (read *query-io*)))) |
---|
326 | |
---|
327 | ;; This modified function offers you a function with the same name in another package. |
---|
328 | (defun undefined-function-called (name arguments) |
---|
329 | (finish-output) |
---|
330 | ;; find all fbound symbols of same name |
---|
331 | (let ((alternatives |
---|
332 | (let ((them nil)) |
---|
333 | (dolist (package (list-all-packages)) |
---|
334 | (let ((found (find-symbol (string name) package))) |
---|
335 | (when (and (fboundp found) (not (member found them))) |
---|
336 | (push found them)))) |
---|
337 | them))) |
---|
338 | (let ((sys::*restart-clusters* sys::*restart-clusters*)) |
---|
339 | ;; Build and add the restarts |
---|
340 | (dolist (alt alternatives) |
---|
341 | (let ((package (symbol-package alt))) |
---|
342 | (let ((alt alt) (package package)) |
---|
343 | (push |
---|
344 | (list (system::make-restart :name |
---|
345 | (intern (concatenate 'string "USE-FROM-" (package-name package))) |
---|
346 | :function |
---|
347 | #'(lambda (&rest ignore) |
---|
348 | (declare (ignore ignore)) |
---|
349 | (shadowing-import alt) |
---|
350 | (setq name (symbol-function alt)) |
---|
351 | (return-from undefined-function-called (apply name arguments))) |
---|
352 | :report-function |
---|
353 | #'(lambda (stream) |
---|
354 | (format stream "Import then use #'~a::~a instead" (string-downcase (package-name package)) alt)))) |
---|
355 | sys::*restart-clusters*)))) |
---|
356 | (loop |
---|
357 | (restart-case |
---|
358 | (error 'undefined-function :name name) |
---|
359 | (continue () |
---|
360 | :report "Try again.") |
---|
361 | (use-value (value) |
---|
362 | :report "Specify a function to call instead." |
---|
363 | :interactive query-function |
---|
364 | (return-from undefined-function-called |
---|
365 | (apply value arguments))) |
---|
366 | (return-value (&rest values) |
---|
367 | :report (lambda (stream) |
---|
368 | (format stream "Return one or more values from the call to ~S." name)) |
---|
369 | :interactive query-function |
---|
370 | (return-from undefined-function-called |
---|
371 | (values-list values))))) |
---|
372 | (when (fboundp name) |
---|
373 | (return-from undefined-function-called (apply name arguments)))))) |
---|