match

まだまだ機能が足りないが match を書いている。パターンマッチも（最適化と汎用性を気にしなければ）難しくはない。

(def-secd-machine secd-1 "secd machine"
  ;; initial state -> transformed state
  ( s e (:NIL . c) d                         -> (nil . s) e c d )
  ( s e (:LDC x . c) d                       -> (x . s) e c d )
  ( s e (:LD (m . n) . c) d                  -> (x . s) e c d where x = (locate m n e) )
  ( s e (:LDF |c'| . c) d                    -> ((|c'| . e) . s) e c d )
  ( (x . s) e (:SEL cT cF . c) d             -> s e cX (c . d) where cX = (if x cT cF) )
  ( s e (:JOIN . c) (cr . d)                 -> s e cr d )
  ( ((|c'| . |e'|) v . s) e (:AP . c) d      -> nil (v . |e'|) |c'| (s e c . d) )
  ( (a b . s) e (:CONS . c) d                -> ((a . b) . s) e c d )
  ( ((a . b) . s) e (:CAR . c) d             -> (a . s) e c d )
  ( ((a . b) . s) e (:CDR . c) d             -> (b . s) e c d )
  ( (x . z) |e'| (:RTN . |c'|) (s e c . d)   -> (x . s) e c d )
  ( (a b . s) e (:+ . c) d                   -> (x . s) e c d where x = (+ a b) )
  ( (a b . s) e (:- . c) d                   -> (x . s) e c d where x = (- a b) )
  ( (a b . s) e (:* . c) d                   -> (x . s) e c d where x = (* a b) )
  ( (a b . s) e (:= . c) d                   -> (x . s) e c d where x = (= a b) )
  ( (a b . s) e (:> . c) d                   -> (x . s) e c d where x = (> a b) )
  ( (a b . s) e (:< . c) d                   -> (x . s) e c d where x = (< a b) )
  )

(defmacro def-secd-machine (name doc &rest body)
  (let ((s (gensym "S ")) (e (gensym "E ")) (c (gensym "C ")) (d (gensym "D ")))
    `(progn
       (defun ,name (,s ,e ,c ,d)
         ,doc
         (tagbody
          :loop
            (format t ";; ~s~%" (list ,s ,e ,c ,d))
            (match (list ,s ,e ,c ,d)
              ,@(loop :for rule :in body
                   :collect
                   (match rule
                     ((s0 e0 c0 d0 :_ s1 e1 c1 d1 'where var '= init-form)
                      `((,s0 ,e0 ,c0 ,d0)
                        (let ((,var ,init-form))
                          (psetq ,s ,(pattern->cons s1)
                                 ,e ,(pattern->cons e1)
                                 ,c ,c1
                                 ,d ,(pattern->cons d1))
                          (go :loop))))
                     ((s0 e0 c0 d0 :_ s1 e1 c1 d1)
                      `((,s0 ,e0 ,c0 ,d0)
                        (psetq ,s ,(pattern->cons s1)
                               ,e ,(pattern->cons e1)
                               ,c ,c1
                               ,d ,(pattern->cons d1))
                        (go :loop))))))
            (values 'stop ,s))))))