(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)) |
This comment has been minimized.
This comment has been minimized.
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
This comment has been minimized.
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!