Permalink
Cannot retrieve contributors at this time
; A basic lisp interpreter, based on SICP chapter 4. | |
; See tests at bottom of file for usage. | |
(ns lisptwo | |
(:use clojure.test)) | |
; Forward declarations | |
(declare env-get env-set env-extend seq-to-map) | |
(declare context context-exp context-env) | |
(declare self-eval? if-eval seq-eval map-eval) | |
(declare do-apply primitive-fn? primitive-fns fn-apply pr-apply) | |
(declare make-fn fn-args fn-body) | |
(defmacro def-context-fn | |
"Defines a fn that takes as its sole argument a context, and creates bindings | |
`c`, `exp` and `env` from that context for use in the fn." | |
[name arg-names & body] | |
(let [c# (nth arg-names 0) | |
exp# (nth arg-names 1) | |
env# (nth arg-names 2)] | |
`(defn ~name [~c#] | |
(let [~exp# (context-exp ~c#) | |
~env# (context-env ~c#)] | |
~@body)))) | |
(def-context-fn do-eval [c exp env]; "Main eval loop" | |
(let [tagged? #(= % (first exp))] | |
(cond (self-eval? exp) c | |
(symbol? exp) (context (env-get env exp) env) | |
(tagged? 'set) (context (last exp) (env-set env (seq-to-map (rest exp)))) | |
(tagged? 'if) (if-eval c) | |
(tagged? 'fn) (context (make-fn c) env) | |
(tagged? 'begin) (seq-eval (context (rest exp) env)) | |
(list? exp) (do-apply c) | |
:else (context 'fail env)))) | |
(def-context-fn do-apply [c exp env] ; "Main apply function" | |
(let [f (first exp) | |
args-context (map-eval (context (rest exp) env)) | |
args (context-exp args-context) | |
env (context-env args-context) | |
applier (if (primitive-fn? f) pr-apply fn-apply)] | |
(context (applier env f args) env))) | |
(defn pr-apply [env f args] | |
(apply (primitive-fns f) args)) | |
(defn fn-apply [env f args] | |
(let [env (env-extend env (fn-args f) args)] | |
(-> (do-eval (context (fn-body f) env)) context-exp))) | |
(defn context [exp env] {'exp exp, 'env env}) | |
(defn context-exp [c] (c 'exp)) | |
(defn context-env [c] (c 'env)) | |
(def-context-fn make-fn [c exp env] | |
(list 'procedure (nth exp 1) (nth exp 2) env)) | |
(defn fn-args [f] (nth f 1)) | |
(defn fn-body [f] (nth f 2)) | |
(defn detect [f coll] | |
(first (filter f coll))) | |
(defn env-set [env pair] | |
(concat [(merge (first env) pair)] (rest env))) | |
(defn env-get [env label] | |
(let [matching-env (detect #(contains? % label) env)] | |
(if (nil? matching-env) | |
'fail-var-lookup | |
(matching-env label)))) | |
(defn env-extend [env labels values] | |
(concat [(apply array-map (interleave labels values))] env)) | |
(defn seq-to-map [seq] | |
(apply array-map seq)) | |
(def primitive-fns { | |
'+ + | |
'- - | |
'* * | |
'/ / | |
'println println | |
}) | |
(defn primitive-fn? [f] | |
(contains? primitive-fns f)) | |
(defn self-eval? [exp] | |
(cond (number? exp) true | |
(string? exp) true | |
(instance? Boolean exp) true | |
:else false)) | |
(def-context-fn if-eval [c exp env] | |
(let [predicate (nth exp 1) | |
consequent (nth exp 2) | |
alternative (if (= 4 (count exp)) (nth exp 3) false) | |
predicate-context (do-eval (context predicate env)) | |
predicate-result (context-exp predicate-context) | |
env (context-env predicate-context)] | |
(do-eval (if predicate-result | |
(context consequent env) | |
(context alternative env))))) | |
(defn map-reducer [a x] | |
(let [result (do-eval (context x (context-env a)))] | |
(context (conj (context-exp a) (context-exp result)) (context-env result)))) | |
(defn last-exp-reducer [a x] | |
(do-eval (context x (context-env a)))) | |
(def-context-fn seq-eval [c exp env] | |
(reduce last-exp-reducer (context nil env) exp)) | |
(def-context-fn map-eval [c exp env] | |
(reduce map-reducer (context [] env) exp)) | |
; Tests | |
(defn run [exp env] | |
(do-eval (context exp env))) | |
(defn run-val | |
([exp] (run-val exp {})) | |
([exp env] (-> (run exp [env]) context-exp)) | |
) | |
(defn run-env | |
([exp] (run-env exp {})) | |
([exp env] (-> (run exp [env]) context-env first)) | |
) | |
(deftest evaluator-tests | |
(is (= 1 (run-val 1))) | |
(is (= "1" (run-val "1"))) | |
(is (= false (run-val false))) | |
(is (= 2 (run-val '(begin 1 2)))) | |
(is (= 1 (run-val 'x {'x 1}))) | |
(is (= 1 (run-val '(begin x) {'x 1}))) | |
(is (= 1 (run-val '(begin (set x 1) x)))) | |
(is (= 1 (run-val '((fn [] 1))))) | |
(is (= 1 (run-val '((fn [] x)) {'x 1}))) | |
(is (= 1 (run-val '((fn [x] x) 1) {'x 2}))) | |
(is (= 2 (run-val '((fn [y] x) (set x 2)) {'x 1}))) | |
(is (= 2 (run-val '(begin ((fn [x] x) 1) x) {'x 2}))) | |
(is (= false (run-val '(if false 1)))) | |
(is (= 1 (run-val '(if true 1 2)))) | |
(is (= 2 (run-val '(if false 1 2)))) | |
(is (= 1 (run-val '(if (set x 1) x)))) | |
(is (= 3 (run-val '(+ 1 (+ 1 1))))) | |
(is (= 3 (run-val '(+ 1 2)))) | |
(is (= 3 (run-val '(- 5 2)))) | |
(is (= 6 (run-val '(* 3 2)))) | |
(is (= 3 (run-val '(/ 6 2)))) | |
(is (= {'x 1} (run-env '(set x 1)))) | |
(is (= {'x 1} (run-env '(+ (set x 1))))) | |
) | |
(run-tests) |