Created
April 7, 2014 11:26
-
-
Save gmorpheme/10018564 to your computer and use it in GitHub Desktop.
From Lisp in Small Pieces chapter 2
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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