Stupid pattern matching tricks

There are a few pattern matching constructs in Common Lisp. For instance, destructuring-bind matches list structure against a tree of variable names and binds the variables accordingly. Macros can destructure their argument list. Even functions have simple keyword matching. These constructs don't give access to their pattern matchers as first-class objects, but perhaps you want that. You can construct a simple pattern matcher by wrapping one of these constructs in the appropriate macro.

We'll want the result of our pattern match to be an alist mapping symbols to the objects they matched with. First, we'll need a function that takes a pattern and returns a list of the variables in the pattern. flatten will work nicely for destructuring-bind:

(defun flatten (pattern)
  (cond ((null pattern) '())
 ((symbolp pattern) (list pattern))
 ((consp pattern) (append (flatten (car pattern))
     (flatten (cdr pattern))))
 (t (error "Not a pattern"))))

CL-USER> (flatten '((a b . c) d e . f))
(A B C D E F)

Then we want to generate code that will make an alist:

CL-USER> `(list ,@(map 'list (lambda (var)
           `(cons ',var ,var))
               (flatten '((a b . c) d e . f))))
(LIST (CONS 'A A) (CONS 'B B) (CONS 'C C) (CONS 'D D) (CONS 'E E) (CONS 'F F))

Finally, we wrap a call to destructuring-bind with a macro:

CL-USER> (defmacro destructuring-pattern-matcher (pattern)
           `(lambda (form)
              (destructuring-bind ,pattern form
                (list ,@(map 'list (lambda (var)
                              `(cons ',var ,var))
                     (flatten pattern))))))
DESTRUCTURING-PATTERN-MATCHER

CL-USER> (destructuring-pattern-matcher ((a b . c) d e . f))
#<FUNCTION (LAMBDA (FORM)) {10027B143B}>

destructuring-pattern-matcher returns a pattern matcher as a first-class procedure we can call on a pattern to get an alist of bindings:

CL-USER> (defvar *matcher* (destructuring-pattern-matcher ((a b . c) d e . f)))
*MATCHER*

CL-USER> (funcall *matcher* '((1 2 3 4) 5 6 7 8))
((A . 1) (B . 2) (C 3 4) (D . 5) (E . 6) (F 7 8))

We can use this trick to get at the destructuring pattern match done by defmacro. First, we need a function that takes a macro lambda list and returns a list of the variables it binds. I won't reproduce the function here, it is too large, but here's a sample call:

CL-USER> (macro-lambda-list-variables 
            '((foo bar &optional (baz 'default baz-supplied-p) . more) quux
              &rest rest
              &key ((:key key-variable) 'key-default key-supplied-p) key2
              &aux (auxvar 'auxvalue)))
(FOO BAR BAZ BAZ-SUPPLIED-P MORE QUUX REST KEY-VARIABLE KEY-SUPPLED-P KEY2 AUXVAR)

If we were matching the list '(1 e) against the pattern (a b &optional c), we'd want to generate code something like this:

(MACROLET ((MACRO (A B &OPTIONAL C)
             (LIST 'LIST
     (LIST 'CONS ''A (LIST 'QUOTE A))
     (LIST 'CONS ''B (LIST 'QUOTE B))
                   (LIST 'CONS ''C (LIST 'QUOTE C)))))
  (MACRO 1 E))

We'll do this in stages:

(defun make-macro-pattern-matcher-body (pattern)
  `(list 
    'list
    ,@(map 'list (lambda (var)
     `(list 'cons '',var `',,var))
    (macro-lambda-list-variables pattern))))

(defun make-macro-pattern-matcher (pattern)
  (let ((body (make-macro-pattern-matcher-body pattern)))
    (lambda (form)
      `(macrolet ((macro ,pattern
      ,body))
  (macro ,@form)))))

(defmacro macro-pattern-matcher (pattern)
  (let ((matcher  (make-macro-pattern-matcher pattern)))
    `(lambda (form)
       (eval (funcall ',matcher form)))))

Now we can make a pattern matcher that works like the macro destructuring facility:

CL-USER> (setq *matcher* 
            (macro-pattern-matcher 
       ((foo bar &optional (baz 'default baz-supplied-p) . more) quux
               &rest rest
               &key ((:key key-variable) 'key-default key-supplied-p) key2
               &aux (auxvar 'auxvalue))))
#<FUNCTION (LAMBDA (FORM)) {10027B1D3B}>

CL-USER> (funcall *matcher* '((1 2 3 4) 5 :key 6 :key2 7))
((FOO . 1)
 (BAR . 2)
 (BAZ . 3)
 (BAZ-SUPPLIED-P . T)
 (MORE 4)
 (QUUX . 5)
 (REST :KEY 6 :KEY2 7)
 (KEY-VARIABLE . 6)
 (KEY-SUPPLIED-P . T)
 (KEY2 . 7)
 (AUXVAR . AUXVALUE))

You can do a similar trick with regular lambda lists, but while they have keywords, they don't destructure.

You have to be careful when writing the expansion for the binding alist. Too much quoting and you end up with the names rather than their values in the output:

((foo . foo)
 (bar . bar)
 …etc…)

not enough, you end up with the values of the values in the output:

CL-USER> (defvar e 22)
E

CL-USER> (funcall *matcher* '((1 2 e) 5))
((FOO . 1)
 (BAR . 2)
 (BAZ . 22) ; Wrong! Should be 'E
 …etc…)