Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
From Lisp in Small Pieces chapter 2
(ns ^{:doc "The lisp_3 evaluator from ch2 of Lisp in Small Pieces"}
lisp.chapter2.lisp3
(:refer-clojure :exclude [extend]))
(defn wrong [& msgs]
(throw (RuntimeException. (apply str (interpose " " msgs)))))
(defprotocol IEnvironment
(lookup [_ k]
"Retrieve value of k in environment."))
(defprotocol IMutableEnvironment
(update! [_ k v]
"Set internal state. Assumes binding exists for update.")
(initialise! [_ k v]
"Provide a new binding and initial value."))
(defprotocol IExtensibleEnvironment
"Return new environment extending the old with supplied bindings."
(extend [_ ks vs]))
(deftype AtomAListEnvironment [a-list]
IEnvironment
(lookup [_ k]
(letfn [(lookup* [id r]
(let [[[k v] & n] r]
(if (= k id)
(if (= v :uninitialised)
(wrong "Uninitialised binding" id)
v)
(if n
(lookup* id n)
(wrong "No such binding: " id)))))]
(lookup* k @a-list)))
IMutableEnvironment
(update! [_ k v]
(letfn [(update [r id v]
(if (seq r)
(if (= (ffirst r) id)
(cons [id v] (rest r))
(cons (first r) (update (rest r) id v)))
(wrong "No such binding" id)))]
(swap! a-list update k v)
v))
(initialise! [_ k v]
(swap! a-list #(cons [k v] %)))
IExtensibleEnvironment
(extend [_ ks vs]
(letfn [(extend* [env ks vs]
(cond
(seq? ks) (if (not (empty? ks))
(if (seq? vs)
(cons [(first ks) (first vs)]
(extend* env (rest ks) (rest vs)))
(wrong "Too few values"))
(if (empty? ks)
env
(wrong "Too many values")))
(symbol? vs) (cons [ks vs] env)))]
(AtomAListEnvironment.
(atom
(extend* @a-list ks vs))))))
(defn make-env []
(AtomAListEnvironment. (atom '())))
(declare evlis eprogn make-function evaluate-application)
(defmulti evaluate-sexp (fn [sexp env fenv denv] (first sexp)))
(defn evaluate
[e env fenv denv]
(if (not (seq? e))
;; atom
(cond
(symbol? e) (lookup env e)
(or (number? e) (string? e) (char? e) (= true e) (= false e) (vector? e)) e
:else (wrong "Cannot evaluate " e))
;; else
(evaluate-sexp e env fenv denv)))
(defmethod evaluate-sexp 'quote [[q x] env fenv denv]
x)
(defmethod evaluate-sexp 'if [[s c t f & more] env fenv denv]
(if (evaluate c env fenv denv)
(evaluate t env fenv denv)
(evaluate f env fenv denv)))
(defmethod evaluate-sexp 'begin [[b & more] env fenv denv]
(eprogn more env fenv denv))
(defmethod evaluate-sexp 'set! [[s k v] env fenv denv]
(update! env k (evaluate v env fenv denv)))
(defmethod evaluate-sexp 'lambda [[l args & exps] env fenv denv]
(make-function args exps env fenv))
(defmethod evaluate-sexp 'function [[_ f] env fenv denv]
(if (symbol? f)
(lookup fenv f)
(wrong "Incorrect function " f)))
(defmethod evaluate-sexp 'flet [[_ bindings & body] env fenv denv]
(eprogn
body
env
(extend fenv
(map first bindings)
(map (fn [[name args & fbody]] (make-function args fbody env fenv)) bindings))
denv))
;; from Exercise 2.8... essentially flet but allowing recursion (as
;; per clojure's letfn) - mutates fenv
(defmethod evaluate-sexp 'labels [[_ bindings & body] env fenv denv]
(let [fenv+ (extend fenv (map first bindings) (repeat :uninitialised))]
(doall
(map (fn [[name args & fbody]] (update! fenv+ name (make-function args fbody env fenv+))) bindings))
(eprogn body env fenv+ denv)))
(defmethod evaluate-sexp 'dynamic [[_ n] env fenv denv]
(lookup denv n))
(defmethod evaluate-sexp 'dynamic-set! [[_ n v] env fenv denv]
(update! denv n (evaluate v env fenv denv)))
(defmethod evaluate-sexp 'dynamic-let [[_ bindings & body] env fenv denv]
(eprogn body
env
fenv
(extend denv
(map first bindings)
(map (fn [[k v]] (evaluate v env fenv denv)) bindings))))
(defmethod evaluate-sexp 'let [[_ bindings body] env fenv denv]
(eprogn
body
(extend env
(map (fn [binding]
(if (symbol? binding) binding (first binding))) bindings)
(map (fn [binding]
(if (symbol? binding) :uninitialised (evaluate (second binding) env fenv denv))) bindings))
fenv denv))
(defmethod evaluate-sexp :default [[f & args] env fenv denv]
(evaluate-application f
(evlis args env fenv denv)
env
fenv
denv))
(defn evlis [exps env fenv denv]
(map #(evaluate % env fenv denv) exps))
(defn eprogn [exps env fenv denv]
(if (seq exps)
(last (evlis exps env fenv denv))
'()))
(defn make-function [args body env fenv]
(fn [vals denv]
(eprogn body (extend env args vals) fenv denv)))
(defn evaluate-application [fn args env fenv denv]
(cond
(symbol? fn) ((lookup fenv fn) args denv)
(and (seq fn) (= (first fn) 'lambda)) (eprogn (rest (rest fn))
(extend env (second fn) args)
fenv
denv)
:else (wrong "Incorrect functional term " fn)))
(def env-global (make-env))
(def fenv-global (make-env))
(def denv-global (make-env))
(defmacro definitial
([name]
`(initialise! env-global '~name :uninitialised))
([name value]
`(initialise! env-global '~name ~value)))
(defmacro definitial-function
([n]
`(initialise! fenv-global '~n :uninitialised))
([n value]
`(initialise! fenv-global '~n ~value)))
(defmacro defprimitive [name value arity]
`(definitial-function ~name
(fn [values# denv#]
(if (= ~arity (count values#))
(~value values# denv#)
(wrong "Incorrect arity" (list '~name values#))))))
(definitial-function funcall
(fn [[f & args] denv]
(if f
(f args denv)
f)))
(defprotocol MutableCons
(mcar [self])
(mcdr [self])
(mset-car! [self val])
(mset-cdr! [self val]))
(deftype ArrayCons [ar]
MutableCons
(mcar [_] (aget ar 0))
(mcdr [_] (aget ar 1))
(mset-car! [_ val] (aset ar 0 val))
(mset-cdr! [_ val] (aset ar 1 val)))
(defn mcons [a b]
(ArrayCons. (into-array Object [a b])))
(defn with-denv
"Wrap a function with a version that also accepts a dynamic
environment."
[f]
(fn [args denv]
(apply f args)))
(defprimitive car (with-denv mcar) 1)
(defprimitive cdr (with-denv mcdr) 1)
(defprimitive cons (with-denv mcons) 2)
(defprimitive set-car! (with-denv mset-car!) 2)
(defprimitive set-cdr! (with-denv mset-cdr!) 2)
(defprimitive + (with-denv +) 2)
(defprimitive - (with-denv -) 2)
(defprimitive eq? (with-denv =) 2)
(defprimitive < (with-denv <) 2)
(definitial nul nil)
(definitial |t| true)
(definitial |f| false)
(definitial x)
(definitial y)
(definitial z)
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
(defn chapter2-lisp3 []
(loop []
(print "\n>")
(flush)
(pr (evaluate (read) env-global fenv-global denv-global))
(flush)
(recur)))
(defn -main []
(chapter2-lisp3))
(comment
(flet ((f (x) (+ x (dynamic y))))
(dynamic-let ((y 2)) (f 3)))
(set! x (quote a-sym))
(dynamic-let ((x (quote dyn)))
(car (cdr ((lambda (x) (cons x (cons (dynamic x) nul)))
(quote param)))))
(labels ((odd? (x) (if (eq? 0 x) |f| (even? (- x 1))))
(even? (x) (if (eq? 0 x) |t| (odd? (- x 1)))))
(even? 4))
(flet ((invoke (f x) (funcall f x))
(g (x) 'hello))
(invoke (function g) 'ignored)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment