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

Advertising is good

Lifted from Akita's interview

I think that Ruby have almost all the power I'm used to from Common Lisp. [sic]
- Ola Bini

Unsolicited advertising from a well respected individual, 'nuff said.

Hunchentoot and packages

Over the past couple of years I've been experimenting with a number of CL
http servers and have recently turned to hunchentoot as my platform of choice
which, like the rest of Edi's packages, has found it's way into my heart.

One of the things I've often found rather annoying however (not with
Hunchentoot specifically, this is present in all of the CL web servers
I've experimented with) is that publishing a URL is a twofold process:

a) define your handler function (or something similar) and
b) register that handler with a particular URL.

Now all this becomes a little repetitive so here is a new publisher function
which allows you to publish your package on a particular URL so that any
requests to URL's 'below' that one will be resolved to a function in your package.

We play on one of the less remarked upon CL features (or lack of restrictions)
which allows symbols to start with a #\/ (a forward slash, to those not used to
the CL character macro reader) so we can publish our package on /test define a
function named /foo and automagically have requests to /test/foo mapped
to our /foo handler.

(modified 30/5/2007 16:00)
eg.

(asdf:oos 'asdf:load-op :hunchentoot)
(asdf:oos 'asdf:load-op :cl-who)

(defpackage :pack-test (:use :cl :hunchentoot :cl-who))
(in-package :pack-test)


(defun index ()
  #'(lambda ()
      (with-html-output-to-string (x)
        (:html "The index page"))))

(defun seq-last (seq)
  (aref seq (1- (length seq))))

(defun string->handler (string package)
  (when (string= string "/") (return-from string->handler (index)))
  (multiple-value-bind (sym type) (find-symbol string package)
    (when (and (not (eql type :inherited))
               (fboundp sym))
      (symbol-function sym))))
                                  
(defun create-package-dispatcher (prefix)
  (check-type prefix string)
  (assert (eql (seq-last prefix) #\/) (prefix) "Prefix must end in a / (forward slash)")
  #'(lambda (request)
      (let* ((function (script-name request))
             (mismatch (mismatch (script-name request) prefix
                                 :test #'char=)))
        (when (or (null mismatch)
                  (>= mismatch (length prefix)))
          (string->handler (string-upcase (subseq function (1- (length prefix))))
                           *package*)))))

(push (create-package-dispatcher "/test/") *dispatch-table*)

(defun /index ()
  (with-html-output-to-string (out)
    (:html (:head (:title "Welcome"))
           (:body (:h2 "This is my welcome page")))))

(defvar *server* (start-server :port 8080))

and now browsing to http://localhost:8080/test/index should give you a
nice new welcome page and adding a new URL is a simple 1 step process.


---
This post is courtesy of lispworks(5.0.2), hunchentoot(0.9.2) and cl-who (0.4.4)

asdf-install & Windows

Thanks to Nate's latest release of archive we can now use asdf-install on Windows
without resorting to cygwin or gnu-tar. Just add the following to your .asdf-install.

(asdf:oos 'asdf:load-op :gzip-stream)
(asdf:oos 'asdf:load-op :archive :version "0.6")

(defun asdf-install-extractor (to-dir tarball)
(let ((name nil))
  (gzip-stream:with-open-gzip-file (ins tarball)
    (archive:with-open-archive (archive ins)
      (let ((*default-pathname-defaults* (pathname to-dir)))
        (archive:do-archive-entries (entry archive name)
          (archive:extract-entry archive entry)
          (unless name (setf name (archive:name entry)))))))
  ;; we use string instead of namestring because
  ;; asdf-install searches for /'s and not \'s
  ;; which will break on windows
  (string name)))

(push 'asdf-install-extractor asdf-install:*tar-extractors*)

You will still get an error along the lines of
"'gpg' is not recognized as an internal or external command,"
but select the continue restart and all should be fine and dandy.


---
This post is courtesy of lispworks(5.0.2), gzip-stream(0.1), asdf-install(0.5.5) and archive(0.6).

Feisty Friday

OK so it's not Friday, but Ubuntu Feisty Fawn has been released.

I've been constantly impressed with each release of Ubuntu and
can heartily recommend it to anyone who wants to see what Linux
is like.

ORF and values

As it turns out my previous post does not allow a values form as a place (the macro expands into invalid code).

So here is an updated version which behaves as follows.
When provided with a values form then for each place n, if n is nil
then n will be set to the nth value returned by the values-form.

eg.

(let ((a 1)
     b
     (c 3))
 (orf (values a b c) (values 4 2 5))
 (values a b c))

=> 1,2,3

And here it is in all it's glory.

(defmacro orf (place value-form &environment env)
 (multiple-value-bind (vars vals store-vars writer reader)
     (get-setf-expansion place env)
   (let ((tmp-var (loop repeat (length store-vars) collect (gensym))))
     `(let* (,@(mapcar 'list vars vals))
        (multiple-value-bind ,store-vars ,reader
          (multiple-value-bind ,tmp-var ,value-form
            ,@(loop for store in store-vars for val in tmp-var
                    collect `(unless  ,store (setf ,store ,val)))
            ,writer))))))

orf (a Common Lisp version of ||=)

I've recently been programming in ruby and one of the handy operators I've
been using has been ||= .

If you haven't seen it before think of it in terms of += .
So x ||= 3 is equivalent to x = x || 3.

I've found this pretty useful in a couple of cases and decided to write a
CL implementation of it. I give you ORF.



(defmacro orf (place value &environment env)
 (multiple-value-bind (vars vals store-vars writer reader)
   (get-setf-expansion place env)
 `(let* (,@(mapcar 'list vars vals)
         (,@store-vars (or ,reader ,value)))
    ,writer)))

So now (orf x 3) === (setf x (or x 3))

with the minor caveat that x will only being evaluated once.

Truly, Lisp is the Borg of programming languages.