(defun destruc (pat seq &optional (atom? #'atom) (n 0)) (if (null pat) nil (let ((rest (cond ((funcall atom? pat) pat) ((eq (car pat) '&rest) (cadr pat)) ((eq (car pat) '&body) (cadr pat)) (t nil)))) (if rest `((,rest (subseq ,seq ,n))) (let ((p (car pat)) (rec (destruc (cdr pat) seq atom? (1+ n)))) (if (funcall atom? p) (cons `(,p (elt ,seq ,n)) rec) (let ((var (gensym))) (cons (cons `(,var (elt ,seq ,n)) (destruc p var atom?)) rec)))))))) (defmacro pat-match (pat seq then else) (if (simple? pat) (match1 `((,pat ,seq)) then else) (with-gensyms (gseq gelse) `(labels ((,gelse () ,else)) ,(gen-match (cons (list gseq seq) (destruc pat gseq #'simple?)) then `(,gelse)))))) (defun simple? (x) (or (atom x) (eq (car x) 'quote))) (defun gen-match (refs then else) (if (null refs) then (let ((then (gen-match (cdr refs) then else))) (if (simple? (caar refs)) (match1 refs then else) (gen-match (car refs) then else))))) (defun match1 (refs then else) (dbind ((pat expr) . rest) refs (cond ((gensym? pat) `(let ((,pat ,expr)) (if (and (typep ,pat 'sequence) ,(length-test pat rest)) ,then ,else))) ((eq pat '_) then) ((var? pat) (let ((ge (gensym))) `(let ((,ge ,expr)) (if (or (gensym? ,pat) (equal ,pat ,ge)) (let ((,pat ,ge)) ,then) ,else)))) (t `(if (equal ,pat ,expr) ,then ,else))))) (defun gensym? (s) (and (symbolp s) (not (symbol-package s)))) (defun length-test (pat rest) (let ((fin (caadar (last rest)))) (if (or (consp fin) (eq fin 'elt)) `(= (length ,pat) ,(length rest)) `(> (length ,pat) ,(- (length rest) 2)))))