org.armedbear.lisp.restart.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl Show documentation
Show all versions of abcl Show documentation
Common Lisp implementation running on the JVM
;;; restart.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id: restart.lisp 11785 2009-04-26 06:58:46Z ehuelsmann $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
;;; Adapted from CMUCL/SBCL.
(in-package #:system)
(defun read-evaluated-form ()
(fresh-line *query-io*)
(%format *query-io* "Enter a form to be evaluated:~%")
(list (eval (read *query-io*))))
(defvar *restart-clusters* ())
(defvar *condition-restarts* ())
(defstruct restart
name
function
report-function
interactive-function
(test-function #'(lambda (c) (declare (ignore c)) t)))
(defmacro restart-bind (bindings &body forms)
`(let ((*restart-clusters*
(cons (list
,@(mapcar #'(lambda (binding)
`(make-restart
:name ',(car binding)
:function ,(cadr binding)
,@(cddr binding)))
bindings))
*restart-clusters*)))
,@forms))
(defun compute-restarts (&optional condition)
(let ((associated ())
(other ()))
(dolist (alist *condition-restarts*)
(if (eq (car alist) condition)
(setq associated (cdr alist))
(setq other (append (cdr alist) other))))
(let ((res ()))
(dolist (restart-cluster *restart-clusters*)
(dolist (restart restart-cluster)
(when (and (or (not condition)
(member restart associated)
(not (member restart other)))
(funcall (restart-test-function restart) condition))
(push restart res))))
(nreverse res))))
(defun restart-report (restart stream)
(funcall (or (restart-report-function restart)
(let ((name (restart-name restart)))
(lambda (stream)
(if name (%format stream "~S" name)
(%format stream "~S" restart)))))
stream))
(defun print-restart (restart stream)
(if *print-escape*
(print-unreadable-object (restart stream :type t :identity t)
(prin1 (restart-name restart) stream))
(restart-report restart stream)))
(defun find-restart (name &optional condition)
(let ((restarts (compute-restarts condition)))
(dolist (restart restarts)
(when (or (eq restart name) (eq (restart-name restart) name))
(return-from find-restart restart)))))
(defun find-restart-or-control-error (identifier &optional condition)
(or (find-restart identifier condition)
(error 'control-error
:format-control "Restart ~S is not active."
:format-arguments (list identifier))))
(defun invoke-restart (restart &rest values)
(let ((real-restart (find-restart-or-control-error restart)))
(apply (restart-function real-restart) values)))
(defun interactive-restart-arguments (real-restart)
(let ((interactive-function (restart-interactive-function real-restart)))
(if interactive-function
(funcall interactive-function)
'())))
(defun invoke-restart-interactively (restart)
(let* ((real-restart (find-restart-or-control-error restart))
(args (interactive-restart-arguments real-restart)))
(apply (restart-function real-restart) args)))
(defun parse-keyword-pairs (list keys)
(do ((l list (cddr l))
(k '() (list* (cadr l) (car l) k)))
((or (null l) (not (member (car l) keys)))
(values (nreverse k) l))))
(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
(let ((temp (member '&rest names)))
(unless (= (length temp) 2)
(error "&REST keyword is ~:[missing~;misplaced~]." temp))
(let ((key-vars (ldiff names temp))
(key-var (or keywords-var (gensym)))
(rest-var (cadr temp)))
(let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD")))
key-vars)))
`(multiple-value-bind (,key-var ,rest-var)
(parse-keyword-pairs ,expression ',keywords)
(let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
key-vars keywords)
,@forms))))))
(defun transform-keywords (&key report interactive test)
(let ((result ()))
(when report
(setf result (list* (if (stringp report)
`#'(lambda (stream)
(write-string ,report stream))
`#',report)
:report-function
result)))
(when interactive
(setf result (list* `#',interactive
:interactive-function
result)))
(when test
(setf result (list* `#',test :test-function result)))
(nreverse result)))
;; "If the restartable-form is a list whose car is any of the symbols SIGNAL,
;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a
;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the
;; indicated restarts with the condition to be signaled."
(defun munge-restart-case-expression (expression env)
(let ((exp (macroexpand expression env)))
(if (consp exp)
(let* ((name (car exp))
(args (if (eq name 'cerror) (cddr exp) (cdr exp))))
(if (member name '(SIGNAL ERROR CERROR WARN))
(let ((n-cond (gensym)))
`(let ((,n-cond (coerce-to-condition ,(first args)
(list ,@(rest args))
',(case name
(WARN 'simple-warning)
(SIGNAL 'simple-condition)
(t 'simple-error))
',name)))
(with-condition-restarts
,n-cond
(car *restart-clusters*)
,(if (eq name 'cerror)
`(cerror ,(second exp) ,n-cond)
`(,name ,n-cond)))))
expression))
expression)))
(defmacro restart-case (expression &body clauses &environment env)
(let ((block-tag (gensym))
(temp-var (gensym))
(data
(mapcar #'(lambda (clause)
(with-keyword-pairs ((report interactive test
&rest forms)
(cddr clause))
(list (car clause)
(gensym)
(transform-keywords :report report
:interactive interactive
:test test)
(cadr clause)
forms)))
clauses)))
`(block ,block-tag
(let ((,temp-var nil))
(tagbody
(restart-bind
,(mapcar #'(lambda (datum)
(let ((name (nth 0 datum))
(tag (nth 1 datum))
(keys (nth 2 datum)))
`(,name #'(lambda (&rest temp)
(setq ,temp-var temp)
(go ,tag))
,@keys)))
data)
(return-from ,block-tag
,(munge-restart-case-expression expression env)))
,@(mapcan #'(lambda (datum)
(let ((tag (nth 1 datum))
(bvl (nth 3 datum))
(body (nth 4 datum)))
(list tag
`(return-from ,block-tag
(apply #'(lambda ,bvl ,@body)
,temp-var)))))
data))))))
(defmacro with-simple-restart ((restart-name format-string
&rest format-arguments)
&body forms)
`(restart-case (progn ,@forms)
(,restart-name ()
:report (lambda (stream)
(simple-format stream ,format-string ,@format-arguments))
(values nil t))))
(defmacro with-condition-restarts (condition-form restarts-form &body body)
(let ((n-cond (gensym)))
`(let ((*condition-restarts*
(cons (let ((,n-cond ,condition-form))
(cons ,n-cond
(append ,restarts-form
(cdr (assoc ,n-cond *condition-restarts*)))))
*condition-restarts*)))
,@body)))
(defun abort (&optional condition)
(invoke-restart (find-restart-or-control-error 'abort condition))
(error 'control-error
:format-control "ABORT restart failed to transfer control dynamically."))
(defun muffle-warning (&optional condition)
(invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
(defun continue (&optional condition)
(let ((restart (find-restart 'continue condition)))
(when restart
(invoke-restart restart))))
(defun store-value (value &optional condition)
(let ((restart (find-restart 'store-value condition)))
(when restart
(invoke-restart restart value))))
(defun use-value (value &optional condition)
(let ((restart (find-restart 'use-value condition)))
(when restart
(invoke-restart restart value))))
(defun warn (datum &rest arguments)
(let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
(require-type condition 'warning)
(restart-case (signal condition)
(muffle-warning ()
:report "Skip warning."
(return-from warn nil)))
(let ((badness (etypecase condition
(style-warning 'style-warning)
(warning 'warning))))
(fresh-line *error-output*)
(simple-format *error-output* "~S: ~A~%" badness condition)))
nil)
(defun style-warn (format-control &rest format-arguments)
(warn 'style-warning
:format-control format-control
:format-arguments format-arguments))
(defun cerror (continue-string datum &rest arguments)
(with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments))
(let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
(with-condition-restarts condition (list (find-restart 'continue))
(signal condition)
(invoke-debugger condition))))
nil)
(defun query-function ()
(format *query-io* "~&Enter a form to be evaluated: ")
(force-output *query-io*)
(multiple-value-list (eval (read *query-io*))))
(defun undefined-function-called (name arguments)
(finish-output)
(loop
(restart-case
(error 'undefined-function :name name)
(continue ()
:report "Try again.")
(use-value (value)
:report "Specify a function to call instead."
:interactive query-function
(return-from undefined-function-called
(apply value arguments)))
(return-value (&rest values)
:report (lambda (stream)
(format stream "Return one or more values from the call to ~S." name))
:interactive query-function
(return-from undefined-function-called
(values-list values))))
(when (fboundp name)
(return (apply name arguments)))))