Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
(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!

Owner

bloat commented Feb 28, 2015

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment