(define-condition warning () ())
(define-condition style-warning (warning) ())
(define-condition serious-condition () ())
(define-condition storage-condition (serious-condition) ())
(define-condition error (serious-condition) ())
(define-condition type-error (error)
((datum :initarg :datum :accessor type-error-datum)
(expected-type :initarg :expected-type :accessor type-error-expected-type))
(:report (lambda (condition stream)
(format stream "~S is not of type ~S"
(type-error-datum condition)
(type-error-expected-type condition)))))
(define-condition package-error (error)
((package :initarg :package :accessor package-error-package)))
(define-condition control-error (error) ())
(define-condition print-not-readable (error)
((object :initarg :object :accessor print-not-readable-object)))
(define-condition program-error (error) ())
(define-condition file-error (error)
((pathname :initarg :pathname :accessor file-error-pathname)))
(define-condition stream-error (error)
((stream :initarg :stream :accessor stream-error-stream)))
(define-condition end-of-file (stream-error) ())
(define-condition parse-error (error) ())
(define-condition reader-error (parse-error stream-error) ())
(define-condition cell-error (error)
((name :initarg :name :accessor cell-error-name)))
(define-condition unbound-variable (cell-error) ())
(define-condition undefined-function (cell-error) ())
(define-condition unbound-slot (cell-error)
((instance :initarg :incetance :accessor unbound-slot-instance)))
(define-condition arithmetic-error (error)
((operation :initarg :operation :accessor arithmetic-error-operation)
(operands :initarg :operands :accessor arithmetic-error-operands)))
(define-condition division-by-zero (arithmetic-error) ())
(define-condition floating-point-inexact (arithmetic-error) ())
(define-condition floating-point-invalid-operation (arithmetic-error) ())
(define-condition floating-point-overflow (arithmetic-error) ())
(define-condition floating-point-underflow (arithmetic-error) ())
(define-condition simple-condition (condition)
((format-control :initarg :format-control
:accessor simple-condition-format-control)
(format-arguments :initarg :format-arguments
:accessor simple-condition-format-arguments))
(:report (lambda (condition stream)
(apply #'format stream
(simple-condition-format-control condition)
(simple-condition-format-arguments condition)))))
(define-condition simple-warning (simple-condition warning) ())
(define-condition simple-error (simple-condition error) ())
(define-condition simple-type-error (simple-condition type-error) ())
(define-condition simple-program-error (simple-condition program-error) ())
(defun existing-condition-name-p (object)
(and (symbolp object) (subtypep object 'condition)))
(deftype condition-designator ()
'(or string condition (satisfies existing-condition-name-p)))
(defun condition (datum arguments
&optional (default-simple-condition 'simple-condition))
(typecase datum
(condition (when arguments
(error 'type-error :datum arguments :expected-type 'null))
datum)
(string (make-condition default-simple-condition
:format-control
(concatenate 'string *message-prefix* datum)
:format-arguments arguments))
((satisfies existing-condition-name-p)
(apply #'make-condition datum arguments))
(t (error 'type-error :datum datum :expected-type 'condition-designator))))
(defvar *handler-clusters* '())
(defmacro handler-bind (bindings &body forms)
`(let ((*handler-clusters*
(cons (list ,@(mapcar #'(lambda (binding)
(destructuring-bind (type handler) binding
`(cons ',type ,handler)))
bindings))
*handler-clusters*)))
,@forms))
(defun handler-case-bindings-and-body (block-tag condition-variable
handler-case-clauses)
(loop for clause in handler-case-clauses
for (typespec (var) . rest) = clause
for clause-tag = (gensym)
collect `(,typespec #'(lambda (temp)
,(if var
`(setq ,condition-variable temp)
'(declare (ignore temp)))
(go ,clause-tag)))
into bindings
append `(,clause-tag (return-from ,block-tag
(let ,(when var `((,var ,condition-variable)))
,@rest)))
into body
finally (return (values bindings body))))
(defmacro handler-case (form &rest clauses)
(let ((no-error-clause (assoc ':no-error clauses)))
(if no-error-clause
(let ((normal-return (gensym "NORMAL-RETURN-"))
(error-return (gensym "ERROR-RETURN-")))
`(block ,error-return
(multiple-value-call #'(lambda ,@(cdr no-error-clause))
(block ,normal-return
(return-from ,error-return
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause clauses)))))))
(let ((block-tag (gensym))
(condition (gensym)))
(multiple-value-bind (bindings body)
(handler-case-bindings-and-body block-tag condition clauses)
`(block ,block-tag
(let ((,condition nil))
(declare (ignorable ,condition))
(tagbody
(handler-bind ,bindings
(return-from ,block-tag ,form))
,@body))))))))
(defmacro ignore-errors (&body body)
`(handler-case (progn ,@body)
(error (condition) (values nil condition))))
(defstruct (restart (:print-object print-restart))
(name nil :type symbol)
(function (required-argument) :type function)
report-function
interactive-function
(test-function #'(lambda (condition) (declare (ignore condition)) t)))
(defun print-restart (restart stream)
(format stream "#<~A restart (sacla)>" (restart-name restart)))
(defvar *restart-clusters* 'nil)
(defmacro restart-bind (restart-specs &body forms)
"Execute FORMS in a dynamic environment where specified restarts are ~
in effect."
(flet ((make-restart-form (spec)
(destructuring-bind (name function . initargs) spec
`(make-restart :name ',name :function ,function ,@initargs))))
`(let ((*restart-clusters* (cons (list ,@(mapcar #'make-restart-form
restart-specs))
*restart-clusters*)))
,@forms)))
(defvar *condition-restarts* 'nil)
(defmacro with-condition-restarts (condition-form restarts-form &body forms)
"Execute FORMS in an environment where restarts are associated with ~
a condition."
`(let ((*condition-restarts* (acons ,condition-form ,restarts-form
*condition-restarts*)))
,@forms))
(defmacro with-restarts (restarts-form form &environment env)
"Associate a condition to be signaled by FORM with restarts of RESTARTS-FORM."
(flet ((signaling-form-p (form)
(and (consp form) (member (car form) '(cerror error signal warn)))))
(let ((form (macroexpand form env)))
(if (not (signaling-form-p form))
form
(let* ((condition (gensym))
(signaler (car form))
(datum (if (eq signaler 'cerror) (third form) (second form)))
(args (if (eq signaler 'cerror) (cdddr form) (cddr form)))
(default-condition (ecase signaler
((cerror error) 'simple-error)
(warning 'simple-warning)
(signal 'simple-condition))))
`(let ((,condition (condition ,datum ',args ',default-condition)))
(with-condition-restarts ,condition
,restarts-form
,(if (eq signaler 'cerror)
`(cerror ,(second form) ,condition)
`(,signaler ,condition)))))))))
(defun restart-case-bindings-and-body (block-tag args-var restart-case-clauses)
(loop for clause in restart-case-clauses
for (case-name lambda-list . tail) = clause
for clause-tag = (gensym)
for initargs =
(loop for plist on tail by #'cddr
for (key value) = plist
and names = '(:interactive :report :test) then (remove key names)
if (member key names)
if (eq key :interactive)
append `(:interactive-function #',value)
else if (eq key :report)
append `(:report-function
#',(if (not (stringp value))
value
`(lambda (stream)
(write-string ,value stream))))
else if (eq key :test) append `(:test-function #',value)
else do (loop-finish)
finally (setq tail plist))
collect `(,case-name
#'(lambda (&rest rest) (setq ,args-var rest) (go ,clause-tag))
,@initargs) into bindings
append `(,clause-tag
(return-from ,block-tag
(apply #'(lambda ,lambda-list ,@tail) ,args-var))) into body
finally (return (values bindings body))))
(defmacro restart-case (restartable-form &body clauses)
"Eval RESTARTABLE-FORM in an environment with restarts specified by CLAUSES."
(let ((block-tag (gensym))
(args (gensym)))
(multiple-value-bind (bindings body)
(restart-case-bindings-and-body block-tag args clauses)
`(block ,block-tag
(let ((,args nil))
(declare (ignorable ,args))
(tagbody
(restart-bind ,bindings
(return-from ,block-tag
(with-restarts (first *restart-clusters*) ,restartable-form)))
,@body))))))
(defmacro with-simple-restart ((restart-name format-string &rest format-arguments)
&body forms)
`(restart-case (progn ,@forms)
(,restart-name ()
:report (lambda (stream) (format stream ,format-string ,@format-arguments))
(values nil t))))
(defun compute-restarts (&optional condition)
"Compute a list of the restarts which are currently active."
(let ((visibles nil)
(ignorables nil))
(dolist (assoc *condition-restarts*)
(if (eq (car assoc) condition)
(setq visibles (append (cdr assoc) visibles))
(setq ignorables (append (cdr assoc) ignorables))))
(flet ((visible-p (restart)
(and (or (null condition)
(member restart visibles)
(not (member restart ignorables)))
(funcall (restart-test-function restart) condition))))
(loop for restart in (mapcan #'copy-list *restart-clusters*)
if (visible-p restart) collect restart))))
(defun find-restart (id &optional condition)
"Search for a particular restart in the current dynamic environment."
(if (restart-p id)
(if (funcall (restart-test-function id) condition)
id
nil)
(find id (compute-restarts condition) :key #'restart-name)))
(defun restart (designator)
(or (find-restart designator)
(error "Restart ~S is not active." designator)))
(defun invoke-restart (restart-designator &rest values)
(let ((restart (restart restart-designator)))
(apply (restart-function restart) values)))
(defun invoke-restart-interactively (restart-designator)
(let* ((restart (restart restart-designator))
(interactive-function (restart-interactive-function restart)))
(apply (restart-function restart) (if interactive-function
(funcall interactive-function)
'()))))
(defun abort (&optional condition)
(let ((restart (find-restart 'abort condition)))
(when restart
(invoke-restart 'abort))
(error 'control-error)))
(defun muffle-warning (&optional condition)
(let ((restart (find-restart 'muffle-warning condition)))
(when restart
(invoke-restart 'muffle-warning))
(error 'control-error)))
(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 'store-value value))))
(defun use-value (value &optional condition)
(let ((restart (find-restart 'use-value condition)))
(when restart
(invoke-restart 'use-value value))))
(defvar *break-on-signals* 'nil)
(defun break (&optional (format-control "Break") &rest format-arguments)
(with-simple-restart (continue "Return from BREAK.")
(let ((*debugger-hook* nil))
(invoke-debugger (make-condition 'simple-condition
:format-control format-control
:format-arguments format-arguments))))
nil)
(defun signal (datum &rest arguments)
(let ((condition (condition datum arguments))
(*handler-clusters* *handler-clusters*))
(when (typep condition *break-on-signals*)
(break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition))
(loop while *handler-clusters*
do (dolist (handler (pop *handler-clusters*))
(when (typep condition (car handler))
(funcall (cdr handler) condition))))
nil))
(defun error (datum &rest arguments)
(let ((condition (condition datum arguments 'simple-error)))
(signal condition)
(invoke-debugger condition)))
(defun cerror (continue-format-control datum &rest arguments)
(restart-case (error (condition datum arguments 'simple-error))
(continue ()
:report (lambda (stream)
(apply #'format stream continue-format-control arguments))))
nil)
(defmacro check-type (place typespec &optional string)
(declare (ignorable string))
`(loop
until (typep ,place ',typespec)
do (restart-case (error 'type-error :datum ,place :expected-type ',typespec)
(store-value (value)
:report (lambda (stream) (store-value-report stream ',place))
:interactive store-value-interactive
(setf ,place value)))))
(defun warn (datum &rest arguments)
(let ((condition (condition datum arguments 'simple-warning)))
(check-type condition warning)
(restart-case (signal condition)
(muffle-warning ()
:report "Skip warning."
(return-from warn nil)))
(format *error-output* "~&Warning:~%~A~%" condition)
nil))
(defun assert-report (names stream)
(format stream "Retry assertion")
(if names
(format stream " with new value~P for ~{~S~^, ~}." (length names) names)
(format stream ".")))
(defun assert-prompt (name value)
(cond ((y-or-n-p "The old value of ~S is ~S.~%~
Do you want to supply a new value? "
name value)
(format *query-io* "~&Type a form to be evaluated:~%")
(flet ((read-it () (eval (read *query-io*))))
(if (symbolp name) (progv (list name) (list value) (read-it))
(read-it))))
(t value)))
(defmacro assert (test-form &optional places datum-form &rest argument-forms)
`(loop
(when ,test-form (return nil))
(restart-case (error ,@(if datum-form
`(,datum-form ,@argument-forms)
`("The assertion ~S failed." ',test-form)))
(continue ()
:report (lambda (stream) (assert-report ',places stream))
,@(mapcar #'(lambda (place)
`(setf ,place (assert-prompt ',place ,place)))
places)))))
