1;;; restart.lisp 2;;; 3;;; Copyright (C) 2003-2005 Peter Graves 4;;; $Id$ 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(defun undefined-function-called (name arguments) 328 (finish-output) 329 (loop 330 (restart-case 331 (error 'undefined-function :name name) 332 (continue () 333 :report "Try again.") 334 (use-value (value) 335 :report "Specify a function to call instead." 336 :interactive query-function 337 (return-from undefined-function-called 338 (apply value arguments))) 339 (return-value (&rest values) 340 :report (lambda (stream) 341 (format stream "Return one or more values from the call to ~S." name)) 342 :interactive query-function 343 (return-from undefined-function-called 344 (values-list values)))) 345 (when (fboundp name) 346 (return (apply name arguments))))) 347