L.I.S.P.Chapter3.clj

(ns ch3.core)

(defn atom? [e]
  (not (list? e)))

(defn wrong [msg] (throw (RuntimeException. msg)))

(declare evaluate)

(defmulti invoke (fn [r & _] (:type r)))
(defmethod invoke :default [f v* r k] (wrong (str "not a function " f)))

(defmulti lookup (fn [r & _] (:type r)))
(defmethod lookup :default [r n k] (wrong (str "not an environment " r)))

(defmulti update! (fn [r & _] (:type r)))
(defmethod update! :default [r n k v] (wrong (str "not an environment" r)))

(defmulti resume (fn [r & _] (:type r)))
(defmethod resume :default [k v] (wrong (str "unknown continuation" k)))

;; IF
(derive ::if-cont ::continuation)
(defmethod resume ::if-cont [k v] (evaluate (if v (:et k) (:ef k))
                                            (:r k)
                                            (:k k)))

(defn evaluate-if [ec et ef r k]
  (evaluate ec r {:type ::if-cont :k k :et et :ef ef :r r}))

;; QUOTE
(defn evaluate-quote [v r k]
  (resume k v))

;; BEGIN
(derive ::begin-cont ::continuation)

(defn evaluate-begin [e* r k]
  (if (seq e*)
    (if (> (count e*) 1)
      (evaluate (first e*) r {:type ::begin-cont :k k :e* e* :r r})
      (evaluate (first e*) r k))
    (resume k 'empty-begin)))

(defmethod resume ::begin-cont [k v]
  (evaluate-begin (rest (:e* k)) (:r k) (:k k)))

;; VARIABLE
(defn evaluate-variable [n r k] (lookup r n k))

(defmethod lookup ::null-env [r n k] (wrong (str "unknown variable " n)))
(defmethod lookup ::full-env [r n k] (lookup (:others r) n k))

(derive ::vari-env ::full-env)
(defmethod lookup ::vari-env [r n k]
  (if (= n (:name r))
    (resume k @(:value r))
    (lookup (:others r) n k)))

;; SET!
(derive ::set!-cont ::continuation)
(defmethod resume ::set!-cont [k v]
  (update! (:r k) (:n k) (:k k) v))

(defn evaluate-set! [n e r k]
  (evaluate e r {:type ::set!-cont :k k :n n :r r}))

(defmethod update! ::null-env [r n k v]
  (wrong (str "unknown variable" [n r k])))

(defmethod update! ::full-env [r n k v]
  (update! (:others r) n k v))

(defmethod update! ::vari-env [r n k v]
  (if (= n (:name r))
    (do (reset! (:value r) v)
        (resume k v))
    (update! (:others r) n k v)))

;; LAMBDA
(defn evaluate-lambda [n* e* r k]
  (resume k {:type :function :env r :variables n* :body e*}))

(defn extend-env [env names values]
  (if (symbol? names)
    {:type ::vari-env :name names :value (atom values) :others env}
    (reduce (fn [o [n v]] {:type ::vari-env
                           :name n
                           :value (atom v)
                           :others o}) env (zipmap names values))))

;; UNWIND
(defmulti unwind (fn [r & _] (:type r)))
(defmethod unwind :default [k v target]
  (wrong (str "can't unwind: " k " " v " " target)))

(defmethod unwind ::continuation [k v ktarget]
  (if (= k ktarget)
    (resume k v)
    (unwind (:k k) v ktarget)))

(defmethod unwind ::root-cont [k v ktarget]
  (wrong (str "obsolete continuation" v)))

(defmethod unwind ::unwind-protect-cont [k v ktarget]
  (evaluate-begin (:cleanup k)
                  (:r k)
                  {:type ::unwind-cont :k (:k k) :value v :target ktarget}))

(derive ::unwind-cont ::continuation)
(defmethod resume ::unwind-cont [k v]
  (unwind (:k k) (:value k) (:target k)))

;; THROW / CATCH
(derive ::catch-cont ::continuation)
(defmethod resume ::catch-cont [k v]
  (evaluate-begin (:body k) (:r k) {:type ::labeled-cont :k (:k k) :tag v}))

(derive ::labeled-cont ::continuation)
(defmethod resume ::labeled-cont [k v]
  (resume (:k k) v))

(defn evaluate-catch [tag body r k]
  (evaluate tag r {:type ::catch-cont :k k :body body :r r}))

(defmulti catch-lookup (fn [r & _] (:type r)))
(defmethod catch-lookup :default [k tag kk] (wrong "not a continuation"))

(defmethod catch-lookup ::continuation [k tag kk]
  (catch-lookup (:k k) tag kk))

(defmethod catch-lookup ::root-cont [k tag kk]
  (wrong (str "No associated catch " k " " tag " " kk)))

(defmethod catch-lookup ::labeled-cont [k tag kk]
  (if (= tag (:tag k))
    (evaluate (:form kk)
              (:r kk)
              {:type ::throwing-cont :k kk :tag tag :cont k})
    (catch-lookup (:k k) tag kk)))

(derive ::throwing-cont ::continuation)
(defmethod resume ::throwing-cont [k v]
  (unwind (:k k) v (:cont k)))

(derive ::throw-cont ::continuation)
(defmethod resume ::throw-cont [k tag]
  (catch-lookup k tag k))

(defn evaluate-throw [tag form r k]
  (evaluate tag r {:type ::throw-cont :k k :form form :r r}))

;; BLOCK

(derive ::block-cont ::continuation)
(defmethod resume ::block-cont [k v]
  (resume (:k k) v))

(derive ::block-env ::full-env)
(defn evaluate-block [label body r k]
  (let [k {:type ::block-cont :k k :label label}]
    (evaluate-begin body {:type ::block-env :others r :name label :k k} k)))

(defmulti block-lookup (fn [r & _] (:type r)))
(defmethod block-lookup :default [f v* r k] (wrong (str "not an environment " r)))

(defmethod block-lookup ::block-env [r n k v]
  (if (= n (:name r))
    (unwind k v (:k r))
    (block-lookup (:others r) n k v)))

(defmethod block-lookup ::full-env [r n k v]
  (block-lookup (:others r) n k v))

(defmethod block-lookup ::null-env [r n k v]
  (wrong (str "unknown block label " n r k v)))

(derive ::return-from-cont ::continuation)
(defmethod resume ::return-from-cont [k v]
  (block-lookup (:r k) (:label k) (:k k) v))

(defn evaluate-return-from [label form r k]
  (evaluate form r {:type ::return-from-cont :k k :r r :label label}))

;; UNWIND-PROTECT

(defn evaluate-unwind-protect [form cleanup r k]
  (evaluate form r {:type ::unwind-protect-cont :k k :cleanup cleanup :r r}))

(derive ::unwind-protect-cont ::continuation)
(defmethod resume ::unwind-protect-cont [k v]
  (evaluate-begin (:cleanup k)
                  (:r k)
                  {:type ::protect-return-cont :k (:k k) :value v}))

(derive ::protect-return-cont ::continuation)
(defmethod resume ::protect-return-cont [k v]
  (resume (:k k) (:value k)))

;; APPLICATION
(defmethod invoke :function [f v* r k]
  (let [env (extend-env (:env f) (:variables f) v*)]
    (evaluate-begin (:body f) env k)))

(defn evaluate-application [e e* r k]
  (evaluate e r {:type ::evfun-cont :k k :e* e* :r r}))

(defn evaluate-arguments [e* r k]
  (if (seq e*)
    (evaluate (first e*) r {:type ::argument-cont :k k :e* e* :r r})
    (resume k nil)))

(derive ::evfun-cont ::continuation)
(defmethod resume ::evfun-cont [k f]
  (evaluate-arguments (:e* k) (:r k) {:type ::apply-cont :k (:k k) :f f :r (:r k)}))

(derive ::argument-cont ::continuation)
(defmethod resume ::argument-cont [k v]
  (evaluate-arguments (rest (:e* k))
                      (:r k)
                      {:type ::gather-cont :k (:k k) :v v}))

(derive ::gather-cont ::continuation)
(defmethod resume ::gather-cont [k v*]
  (resume (:k k) (conj v* (:v k))))

(derive ::apply-cont ::continuation)
(defmethod resume ::apply-cont [k v]
  (invoke (:f k) v (:r k) (:k k)))

;; EVAL
(defn evaluate [e r k]
  (if (atom? e)
    (cond (symbol? e) (evaluate-variable e r k)
          :else (evaluate-quote e r k))
    (case (first e)
      quote (evaluate-quote (second e) r k)
      if (evaluate-if (second e) (nth e 2) (nth e 3) r k)
      begin (evaluate-begin (rest e) r k)
      set! (evaluate-set! (second e) (nth e 2) r k)
      lambda (evaluate-lambda (second e) (rest (rest e)) r k)
      catch (evaluate-catch (second e) (rest (rest e)) r k)
      throw (evaluate-throw (second e) (first (rest (rest e))) r k)
      block (evaluate-block (second e) (rest (rest e)) r k)
      return-from (evaluate-return-from (second e) (first (rest (rest e))) r k)
      unwind-protect (evaluate-unwind-protect (second e) (rest (rest e)) r k)
      (evaluate-application (first e) (rest e) r k))))

;; PRIMITIVES 
(defmethod invoke :primitive [f v* r k]
  ((:f f) v* r k))

(defn primitive [e [name f & arity]]
  {:type ::vari-env
   :name name
   :value (atom {:type :primitive
                 :name name
                 :f (if arity
                      (fn [v* r k]
                        (if (= (first arity) (count v*))
                          (resume k (apply f v*))
                          (wrong (str "Incorrect arity" name v* (first arity)))))
                      f)})
   :others e})

;; CONTINUATIONS
(defmethod invoke ::continuation [f v* r k]
  (if (= 1 (count v*))
    (resume f (first v*))
    (wrong (str "Continuations expect one argument" v* r k))))

;; INITIAL ENVIRONMENT
(def r-init
  (reduce primitive
          {:type ::null-env}
          [['quit (fn [] (throw (IllegalStateException.))) 0]
           ['car first 1]
           ['cons (fn [x y] (cons x (if (not (seq? y)) (list y) y))) 2]
           ['* * 2]
           ['call-cc (fn [v* r k]
                       (if (= (count v*) 1)
                         (invoke (first v*) [k] r k)
                         (wrong (str "Incorrect arity" 'call-cc v*))))]]))

;; START THE INTERPRETER
(derive ::root-cont ::continuation)
(defmethod resume ::root-cont [k v] ((:f k) v))

(def root-cont {:type ::root-cont :f println})

(defn chapter3-interpreter []
  (try
    (loop []
      (evaluate (read) r-init root-cont)
      (recur))
    (catch IllegalStateException e
      nil)
    (catch RuntimeException e
      (.getMessage e))))

(defmacro ch3-eval [form]
  `(evaluate (quote ~form) r-init root-cont))

Ha! Snap.
https://gist.github.com/gmorpheme/310752032a2517daebf2
http://gmorpheme.net/lisp-in-small-pieces-of-clojure-part-3.html

I'm going to be fascinated to look through this and see what we've done differently!

Yours looks interesting. I'd thinking about trying a version with protocols, but went for the quick and dirty approach in the end. Thanks for sharing.