(defvar *handlers* () "Alist of condition name to handler")
(defvar *old-handlers* () "Var to save the bindings of *handlers*")
(defclass root-error ()
((message :initarg :message :accessor message-of :initform "Unknown"))
(:documentation "Our base error class."))
(defun raise (class text)
"signals an error of class CLASS with message TEXT."
(let ((handler (get-handler class)))
(if handler
(invoke-handler handler (make-instance class :message text))
;; This is our 'we crash now'
(error text))))
;; We implement our handlers as functions.
(defun invoke-handler (handler class)
(funcall handler class))
(defun get-handler (class)
"Finds the first handler on *handlers* which is registered with a class
which CLASS is a subtype of."
(cdr (find-if (lambda (handler) (subtypep class handler))
*handlers* :key 'car)))
(defun add-handlers (&rest handlers)
"Takes a list of (class . handler) forms and creates a new
list which can be used as *handlers*"
(append handlers *handlers*))
;;; And all that is left now is to implement trycatch
(defmacro trycatch (form &body error-bindings)
(let* ((block (gensym "BLOCK"))
;; turns each handler into a list of (tmpvar classname handler-fn)
;; its important that we save the state of *handlers* to prevent
;; using the handler bindings we are a part of if we signal an error
;; from within a handler.
(binds (loop for (name args . body) in error-bindings
collect (list (gensym) name `(lambda ,args
(let ((*handlers* *old-handlers*))
(return-from ,block (progn ,@body))))))))
`(block ,block
(let* ((*old-handlers* *handlers*)
;; binds our tmpvar to the handler-function
,@(mapcar (lambda (bind) (list (first bind) (third bind)))
binds))
;; and add (classname . handler-fn) to *handlers*
(let ((*handlers* (add-handlers ,@(mapcar (lambda (bind)
`(cons ',(second bind) ,(first bind)))
binds))))
,form)))))
;and we now raise and catch errors
(trycatch (raise 'root-error "foo")
(root-error (c) (format t "WE GOT AN ERROR ~A" c)))
(defclass my-error (root-error) ())
(defun test-my-error () (raise 'my-error "Whoops!~%"))
(trycatch (test-my-error)
(my-error (c) (format t "Great it works!~%")))
(trycatch (test-my-error)
(root-error (c) (format t "And subtyping works too~%")))
(trycatch (trycatch (test-my-error)
(root-error (c) (raise 'my-error "new-error"))
(my-error (c) "INNER MY-ERROR HANDLER"))
(my-error (c) "OUTER MY-ERROR HANDLER"))
;; should return "OUTER MY-ERROR HANDLER"
Next step handler-bind[3].
-------------------------------
[1] : http://www.lispworks.com/documentation/HyperSpec/Body/m_hand_1.htm
Slow and renamed to trycatch for namespace reasons.
[2] : hmmmm, is this the start of recursive Greenspunning?
[3] : http://www.lispworks.com/documentation/HyperSpec/Body/m_handle.htm
-----
This post is courtesy of lispworks(5.0.2), emacs22 and lispdoc
3 comments:
Isn't your find-if expression equivalent to
(assoc class *items* :test #'subtypep)
?
Also is *prior-handlers* ever used?
bruce: yes it is, and regarding *prior-handlers*, it a small typo, that'll teach me to restore a file and post.
Also...most common lisp environments are written almost entirely in Common Lisp.
The sacla project takes this to an interesting degree.
Post a Comment