Lisp in Lisp

One of the fantastic things about Common Lisp is discovering how you can write parts of the language in the language itself and I'm not talking about implementing number parsing or some library function but rather a languages control structures. A nice and relatively simple one, is implementing handler-case[1] in portable Common Lisp[2].

(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