Hi,
I have written a macro that does pattern matching and substitution on cons
trees (based on the pattern matcher from Paul Graham's book 'ANSI Common
Lisp'), and I would appreciate any comments on it.
The macro gives a declarative programming style which I find usefull for
parsing embedded languages, writing macro's, etc., but I suspect it has
either been done before, or it is just a bad thing. Any pointers to
something similar, improvements, reasons why it's no good, etc. are welcome.
To show the flavor of the macro I created a variant on Lisp in Lisp from
Paul Graham (see http://www.paulgraham.com/lib/paulgraham/jmc.lisp) with it:
(defun eval. (e a)
(mcase e
((quote ?x) ?x)
((atom ?x) (atom (eval. ?x a)))
((eq ?x ?y) (eq (eval. ?x a) (eval. ?y a)))
((car ?x) (car (eval. ?x a)))
((cdr ?x) (cdr (eval. ?x a)))
((cons ?x ?y) (cons (eval. ?x a) (eval. ?y a)))
((cond . ((?test ?body) . ?rest))
(cond ((eval. ?test a) (eval. ?body a))
('t (eval. (cons 'cond ?rest) a))))
(((label ?name ?fun) . ?z)
(eval. (cons ?fun ?z)
(acons ?name (list 'label ?name ?fun) a)))
(((lambda ?vars ?body) . ?args)
(eval. ?body (append (pair. ?vars (evlis. ?args a)) a)))
((?x . ?y) (eval. (cons (assoc. ?x a) ?y) a))
(?x (cond ((atom ?x) (assoc. ?x a))))))
(defun evlis. (m a)
(cond ((null m) '())
('t (cons (eval. (car m) a) (evlis. (cdr m) a)))))
(defun pair. (x y)
(cond ((null x) '())
('t (acons (car x) (car y) (pair. (cdr x) (cdr y))))))
(defun assoc. (x y)
(cond ((null y) '())
((eq (caar y) x) (cdar y))
('t (assoc. x (cdr y)))))
This should run when the code at the end of the post is loaded (it runs on
my Windows machine with LispWorks personal edition).
Paul (·····················@chello.nl)
My source file containing the mcase macro:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; Pattern matching for cons trees
;;;
;;; Robinson's unification for cons trees that may contain substitution
variables.
;;; A variable matches any other expression, but all occurences of a
variable
;;; have to match, and this last remark is indeed recursive. For example
;;; expression (?x foo ?x) matches expression ((?y ?z) foo (bar ?z)) because
;;; (?y ?z) matches (bar ?z). It gives the binding ((y? . bar) (?x . (bar
?z))).
;;; Substitution of this binding in one of the original expression gives
;;; ((bar ?z) foo (bar ?z)).
;;;
;;; 0. Substitution variables and cons trees
;;; 1. Unification and substitution
;;; 2. Macro mcase
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(in-package "CL-USER")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; 0. Substitution variables and cons trees
;;;
;;; A substitution variable is a Lisp symbol whose first character is a
;;; questionmark. The matching algorithm treats these substitution variables
;;; as special.
;;;
;;; (var? x)
;;; True if x is a symbol whose first character is a questionmark.
;;;
;;; (genvar)
;;; Returns a fresh substitution variable.
;;;
;;; (all-vars x)
;;; Returns all substitution variables from cons tree x.
;;;
;;; (contains-vars? x)
;;; Tests whether a cons tree contains substitution variables. At least
;;; as fast as the equivalent (not (null (all-vars x))).
;;;
;;; (occurs var x)
;;; Test whether substitution variable var occurs in cons tree x. At least
;;; as fast as the equivalent (member var (all-vars x)).
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun var? (x)
(when (symbolp x) (eq (char (symbol-name x) 0) #\?)))
(defun genvar ()
(gensym "?"))
(defun all-vars (x)
(cond ((var? x) (list x))
((consp x) (union (all-vars (car x)) (all-vars (cdr x))))))
(defun contains-vars? (expr)
(cond ((var? expr) t)
((consp expr) (or (contains-vars? (car expr))
(contains-vars? (cdr expr))))))
(defun occurs (var expr)
(cond ((var? expr) (eq var expr))
((consp expr) (or (occurs var (car expr)) (occurs var (cdr
expr))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; 1. Unification and substitution
;;;
;;; (match expr0 expr1 bindings)
;;; True iff the expressions match. As second value returns the most
general
;;; unifier as an alist with variable bindings. Matching terminates at the
;;; cost of an occur check.
;;;
;;; (subs exp bindings)
;;; Returns the expression with all free variables in bindings
substituted.
;;;
;;;
;;; Equality is in this context understood to be literal equality of cons
trees
;;; according to following definition.
;;;
;;; (defun liteq (x y)
;;; (if (and (consp x) (consp y))
;;; (and (liteq (car x) (car y)) (liteq (cdr x) (cdr y)))
;;; (eq x y)))
;;;
;;; If (match x y) yields (t mgu) then predicate (liteq (subs x mgu) (subs y
mgu))
;;; is guaranteed true. Maximum generality of mgu means that for any other
;;; unifier u there exists a binding b such that for any cons tree x
predicate
;;; (liteq (subs x u) (subs (subs x mgu) b)) is true.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun match (x y &optional bindings)
(labels
((bcons (key datum blist)
(acons key datum (subs blist (acons key datum ()))))
(match-var (var expression bindings)
(unless (occurs var expression)
(let ((binding (assoc var bindings)))
(if binding (match (cdr binding) expression bindings)
(values t (bcons var expression bindings)))))))
(cond ((eq x y) (values t bindings))
((var? x) (match-var x y bindings))
((var? y) (match-var y x bindings))
((and (consp x) (consp y))
(multiple-value-bind (okay? mgu)
(match (car x) (car y) bindings)
(when okay?
(match (subs (cdr x) mgu) (subs (cdr y) mgu) mgu)))))))
(defun subs (exp bindings)
(cond ((var? exp) (let ((binding (assoc exp bindings)))
(if binding (cdr binding) exp)))
((consp exp) (cons (subs (car exp) bindings)
(subs (cdr exp) bindings)))
(t exp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; 2. Macro mcase
;;;
;;; (mcase . (expr . ((pattern forms) . rest)))
;;; If cons trees 'expr' and 'pattern' match, it evaluates 'forms' as an
;;; implicit progn with all substitution variables from 'expr' bound to
their
;;; matched value. If they don't match and 'rest' is empty the result is
nil,
;;; otherwise it is (mcase . (expr . rest)).
;;;
;;; Examples:
;;;
;;; (mcase '(14 + 14)
;;; ((?x + ?x) `(2 * ,?x))
;;; ((?x + ?y) `(,?y + ,?x))) = (2 * 14)
;;;
;;; (mcase x
;;; ((apply ?fun ?args)
;;; (format *standard-output* "Calling ~a on arguments ~a using
apply"
;;; ?fun ?args)
;;; 'apply)
;;; ((funcall . (?fun . ?args))
;;; (format *standard-output* "Calling ~a on arguments ~a using
funcall"
;;; ?fun ?args)
;;; 'funcall))
;;;
;;; If the last example is evaluated with x = '(funcall fun 1 2 3) it
prints
;;; "Calling FUN on arguments (1 2 3) using funcall" and returns symbol
;;; 'funcall.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defmacro mcase (expr &body body)
(let ((expr-sym (gensym))
(okay-sym (gensym))
(mgu-sym (gensym)))
`(let ((,expr-sym ,expr))
,(reduce
(lambda (x rest)
(if (match x '(?pattern . ?forms))
(let ((vars (all-vars (car x))))
`(multiple-value-bind (,okay-sym ,mgu-sym)
(match ,expr-sym ',(car x))
(if ,okay-sym
(progn
,@(mapcar
(lambda (y)
`(apply (lambda ,vars
(declare (ignorable ,@vars)) ,y)
(mapcar (lambda (x)
(cdr (assoc x ,mgu-sym)))
',vars)))
(cdr x)))
,rest)))
(error "Invalid mcase form: ~a" x)))
body :from-end t :initial-value ()))))
Paul Griffioen wrote:
> Hi,
>
> I have written a macro that does pattern matching and substitution on cons
> trees (based on the pattern matcher from Paul Graham's book 'ANSI Common
> Lisp'), and I would appreciate any comments on it.
Sorry for the shameless plug. :)
http://common-lisp.net/project/cl-unification
Cheers
--
Marco
> Marco Antoniotti wrote:
>
> Paul Griffioen wrote:
> > Hi,
> >
> > I have written a macro that does pattern matching and substitution on
cons
> > trees (based on the pattern matcher from Paul Graham's book 'ANSI Common
> > Lisp'), and I would appreciate any comments on it.
>
> Sorry for the shameless plug. :)
>
> http://common-lisp.net/project/cl-unification
>
> Cheers
> --
> Marco
Thanks, this looks exactly what I'm looking for (and probably a lot more).
Missed it when googling for it.
Paul