simple lisp interpreter, with continuations

gistfile1.clj

(ns lisp.core)

(defprotocol Continuation
  (resume [this v]))

(defmacro defcontinuation [name [& fields] & body]
  `(defrecord ~(symbol (str name "-cont")) [~'k ~@fields]
     Continuation
     ~@body))

(defmacro cont [t & args]
  (list* (symbol (str "->" (name t) "-cont"))
         args))

(defmulti evaluate (fn [k? & rest] (if (keyword? k?) k? :default)))

(defmethod evaluate :default
  [form env k]
  (if (not (coll? form))
    (if (symbol? form)
      (evaluate :variable form env k)
      (evaluate :quote form env k))
    (case (first form)
      quote (evaluate :quote (second form) env k)
      if (evaluate :if (nth form 1) (nth form 2) (nth form 3) env k)
      begin (evaluate :begin (next form) env k)
      set! (evaluate :set! (nth form 1) (nth form 2) env k)
      lambda (evaluate :lambda (second form) (nnext form) env k)

      (evaluate :apply (first form) (rest form) env k))))

(defmethod evaluate :quote
  [_ form env k]
  (resume k form))

(defmethod evaluate :variable
  [_ n env k]
  (resume k (get @env n)))

(defcontinuation if [t f env]
  (resume [this test]
    (evaluate (if test t f) env k)))

(defmethod evaluate :if
  [_ test t f env k]
  (evaluate test env (cont :if k t f env)))

(defcontinuation begin [exprs env]
  (resume [this v]
    (evaluate :begin exprs env k)))

(defmethod evaluate :begin
  [_ exprs env k]
  (if (seq exprs)
    (if (next exprs)
      (evaluate (first exprs) env (cont :begin k (next exprs) env))
      (evaluate (first exprs) env k))
    (resume k nil)))

;; doesn't throw on non-defined
(defcontinuation set! [n env] ;; env is (atom {..})
  (resume [this v]
    (swap! env assoc n v)
    (resume k v)))

(defmethod evaluate :set!
  [_ n v env k]
  (evaluate v env (cont :set! k n env)))

(defrecord function [vars body env])

(defmethod evaluate :lambda
  [_ vars exprs env k]
  (resume k (->function vars exprs env)))

;; assumes everything is correct
(defcontinuation apply [f env]
  (resume [this vars]
    (let [env (atom (merge @(:env f)
                           (zipmap (:vars f) vars)))]
      (evaluate :begin (:body f) env k))))

(defcontinuation function [exprs env]
  (resume [this f]
    (evaluate :args exprs env (cont :apply k f env))))

(defcontinuation gather [val]
  (resume [this vals]
    (resume k (cons val vals))))

(defcontinuation args [args env]
  (resume [this v]
     (evaluate :args args env (cont :gather k v))))

(defmethod evaluate :args
  [_ args env k]
  (if (seq args)
    (evaluate (first args) env (cont :args k (next args) env))
    (resume k nil)))

(defmethod evaluate :apply
  [_ f args env k]
  (evaluate f env (cont :function k args env)))

(defcontinuation identity [f]
  (resume [this v]
    (f v)))

;; (evaluate form (atom {})
;;           (cont :identity nil identity))