;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 4 18:59:27 2004 ;;;; Contains: Macro for pattern matching on S-exprs (in-package :cl-test) (defmacro pmatch (pattern form) (cond ((consp pattern) (let ((pcar (car pattern)) (pcdr (cdr pattern)) (v (gensym))) (case pcar ((:or) `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:and) `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:not) (assert (eql (length pcdr) 1)) `(not (pmatch ,(car pcdr) ,form))) (t `(let ((,v ,form)) (and (pmatch ,pcar (car ,v)) (pmatch ,pcdr (cdr ,v)))))))) ((eql pattern '_) t) ((null pattern) `(null ,form)) ((symbolp pattern) `(eql (quote ,pattern) ,form)) (t `(eql ,pattern ,form)))) (defmacro matchcase (form &body cases) (let* ((v (gensym)) (cond-cases (mapcar #'(lambda (case) (assert (consp case)) (let ((pattern (car case)) (body (cdr case))) `((pmatch ,pattern ,v) ,@body))) cases))) `(let ((,v ,form)) (cond ,@cond-cases)))) (defmacro matchcase* (form &body cases) (let* ((block-name (gensym "DONE")) (v (gensym))) `(block ,block-name (let ((,v ,form)) (cond ,@(mapcar #'(lambda (case) (assert (consp case)) (let ((pat (car case)) (forms (cdr case)) (fail-name (gensym "FAIL"))) `((block ,fail-name (and (pmatch ,pat ,v) (macrolet ((fail () '(return-from ,fail-name nil))) (return-from ,block-name (progn ,@forms)))))))) cases))))))