pattern-match.lsp 2.01 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
;-*- 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))
sds's avatar
sds committed
12 13
          (pcdr (cdr pattern))
          (v (gensym)))
14
      (case pcar
sds's avatar
sds committed
15 16 17 18 19 20 21 22 23 24 25 26 27
        ((: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))))))))
28 29 30 31 32 33 34 35 36 37
   ((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))
sds's avatar
sds committed
38 39 40 41 42 43 44 45
         (cond-cases
          (mapcar
           #'(lambda (case)
               (assert (consp case))
               (let ((pattern (car case))
                     (body (cdr case)))
                 `((pmatch ,pattern ,v) ,@body)))
           cases)))
46 47 48 49 50
    `(let ((,v ,form))
       (cond ,@cond-cases))))

(defmacro matchcase* (form &body cases)
  (let* ((block-name (gensym "DONE"))
sds's avatar
sds committed
51
         (v (gensym)))
52 53
    `(block ,block-name
       (let ((,v ,form))
sds's avatar
sds committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67
         (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))))))

68