SECD Machine in Lisp

;; List Utilities
(defun head (lst)
  (car lst))

(defun tail (list)
  (cdr list))

;; Lambda Expression
(defun lam-expr (var body)
  `(lambda ,var ,body))

(defun is-lambda (list)
  (and (listp list) (eql 'lambda (car list))))

(defun bv (lam)
  (cadr lam))

(defun body (lam)
  (caddr lam))

;; Closure
(defun clos (e x) 
  `(clos ,e ,x))

(defun is-closure (list)
  (and (listp list) (eql 'clos (car list))))

(defun environment-part (clos)
  (values (cadr clos)
          (caddr clos)))

;; Identifier 
;;
(defun is-identifier (x)
  (and (atom x) (not (is-ap x))))

;; Special Object AP
(defun is-ap (x)
  (eql 'ap x))


;; Environment
(defun look-up (e x)
  (let ((res (cdr (assoc x e))) )
    (if res
      res
      x)))

;; Combination
(defun rator (x)
  (car x))

(defun rand (x)
  (cadr x))

;; SECD Machine
(defun mk-machine-state (s e c d)
  `(,s ,e ,c ,d))

(defun show-machine-state (machine-state)
  (format t "S:~A E:~A C:~A D:~A~%" 
          (car machine-state)
          (cadr machine-state)
          (caddr machine-state)
          (cadddr machine-state)))

(defun transform (machine-state)
  (destructuring-bind (s e c d) machine-state
    (if (null c)
      (if (not (null d))
        (destructuring-bind (ds de dc dd) d
          (values (mk-machine-state (cons (head s) ds) de dc dd) t))
        (values machine-state nil))
      (let ((x (head c)))
        (cond ((is-identifier x)
               (values (mk-machine-state (cons (look-up e x) s) e (tail c) d) t))
              ((is-lambda x)
               (values (mk-machine-state (cons (clos e x) s) e (tail c) d) t))
              ((is-ap x)
               (if (is-closure (head s))
                 (multiple-value-bind (de dx) (environment-part (head s))
                   (values (mk-machine-state nil (cons (cons (bv dx) (cadr s)) de) (list (body dx)) (list (tail (tail s)) e (tail c) d)) t))
                   (values (mk-machine-state (cons (cons (cadr s) (car s)) (tail (tail s))) e (tail c) d) t)))
              ((consp x)
               (values (mk-machine-state s e `(,(rand x) ,(rator x) ap ,@(tail c)) d) t))
              (t nil))))))

(defun run-transform (machine-state)
  (labels ((run-transform% (machine-state status)
             (if (null status)
               machine-state
               (progn 
                 (format t "=> ~A~%" machine-state)
                 (multiple-value-bind (new-state st) (transform machine-state)
                   (run-transform% new-state st))))))
    (run-transform% machine-state t)))

P.J.Landin The mechanical evaluation of expressions (1964)
の中にかかれているTransformの実装です。

 (run-transform (mk-machine-state '() '() `((((lambda x (lambda y y)) a) b)) '())
)
=> (NIL NIL ((((LAMBDA X (LAMBDA Y Y)) A) B)) NIL)
=> (NIL NIL (B ((LAMBDA X (LAMBDA Y Y)) A) AP) NIL)
=> ((B) NIL (((LAMBDA X (LAMBDA Y Y)) A) AP) NIL)
=> ((B) NIL (A (LAMBDA X (LAMBDA Y Y)) AP AP) NIL)
=> ((A B) NIL ((LAMBDA X (LAMBDA Y Y)) AP AP) NIL)
=> (((CLOS NIL (LAMBDA X (LAMBDA Y Y))) A B) NIL (AP AP) NIL)
=> (NIL ((X . A)) ((LAMBDA Y Y)) ((B) NIL (AP) NIL))
=> (((CLOS ((X . A)) (LAMBDA Y Y))) ((X . A)) NIL ((B) NIL (AP) NIL))
=> (((CLOS ((X . A)) (LAMBDA Y Y)) B) NIL (AP) NIL)
=> (NIL ((Y . B) (X . A)) (Y) (NIL NIL NIL NIL))
=> ((B) ((Y . B) (X . A)) NIL (NIL NIL NIL NIL))
=> ((B) NIL NIL NIL)
((B) NIL NIL NIL)