Solve et Coagula

So I’m working on a compiler that compiles Lisp-like code (half lisp half scheme) down to AS2 code. The first thing I had to do was convert the code into cps-style which required that I walk the code structure and manipulate the code. After trying a few different methods I wound up creating the BIND-CASE macro which combines the case/cond statement with a destructuring-bind. It winds up working like this:


(bind-case o
           ((=defun name args &rest body)
            ;the =defun makes sure that
            ;the value in that position is DEFUN
            (print "It's a defun statement"))
              
                          
           (((method &rest args) &rest rest)
            (print "It's some non-defun function call"))
  
           (otherwise
            ;the otherwise is nothing other than
            ;a bind to a single variable called OTHERWISE
            (print "it's something else")))


The macro takes the first argument and tries to bind it to the forms listed in the macro. It tries them in order and if one succeeds then it evaluates the body of that test, inside the body all of the variables from the form are available. Also any symbol that begins with an = requires that the value in that position is equal to the symbol name in that slot (without the = of course).

This macro wound up being quite useful and was way cleaner than the previous method of using DEFMETHOD and nested TYPECASE statements.

Anyway, without further adieu here’s the code. Let me know what you think or if you have any ideas to make it more useful, or if there was something that already did this that I totally overlooked.


(defun starts-with-= (a)
  (and (symbolp a)
       (eq (char (symbol-name a) 0) #\=)))
 
(defun remove-= (a)
  (intern (subseq (symbol-name a) 1)))
 
(defun convert-dbind (a)
  (let (match)
    (labels ((fn (v)
                 (typecase v
                       (cons
                        (cons (fn (car v)) (fn (cdr v))))
                       (otherwise
                        (if (starts-with-= v)
                            (let ((erv (remove-= v)))
                              (push `(eq ,erv ',erv) match)
                              erv)
                          v)))))
      (values (fn a) match))))
 
(defmacro bind-case (val &rest args)
  (let ((rtn (gensym)))
    `(catch ',rtn
       (or
        ,@(mapcar #'(lambda (a)
                      (destructuring-bind (db &rest body) a
                        (multiple-value-bind (b match)
                                               (convert-dbind db)
                          `(ignore-errors
                            (destructuring-bind ,b ,val
                              (and ,@match
                                   (throw ',rtn
                                        (progn ,@body))))))))
            args)))))


This entry was posted on Sunday, August 19th, 2007 at 10:41 pm and is filed under Uncategorized. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.