Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Lisp in Small Pieces of Clojure - chapter one
(ns ^{:doc "Evaluator from ch1 of lisp in small pieces. Warning:
NON-IDIOMATIC clojure!"}
lisp.chapter1.eval
(:refer-clojure :exclude [extend]))
(defn wrong [& msgs]
(throw (RuntimeException. (apply str msgs))))
;; -- runtime support, environments are represented as a seq of pairs,
;; -- stored in an atom. Non-idiomatic but faithful to the book.
(defn lookup
"Lookup symbol id in environment env. Environment is atom containing
seq of pairs."
[id env]
(letfn [(lookup* [id r]
(let [[[k v] & n] r]
(if (= k id)
v
(if n
(lookup* id n)
(wrong "No such binding: " id)))))]
(lookup* id @env)))
(defn update!
"Mutate environment to set id to v. Assumes id already exists."
[id env 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! env update id v)
v))
(defn- extend*
"Extend environment (internal), return extended env."
[r ns vs]
(cond
(seq? ns) (if (not (empty? ns))
(if (seq? vs)
(cons [(first ns) (first vs)]
(extend* r (rest ns) (rest vs)))
(wrong "Too few values"))
(if (empty? ns)
r
(wrong "Too many values")))
(symbol? vs) (cons [ns vs] r)))
(defn extend [env ns vs]
(atom (extend* @env ns vs)))
(def env-init (atom '()))
;; -- the interpreter, relies on underlying clojure for values of
;; -- booleans, and so on (and for read, obivously)
(declare evlis eprogn make-function invoke)
(defn evaluate
"Evaluate form e in environment r."
[e r]
(if (not (seq? e))
; atom
(if (symbol? e)
(lookup e r)
e) ; implicit quote
; list
(case (first e)
quote (second e)
if (let [[c t f] (rest e)] (if (evaluate c r) (evaluate t r) (evaluate f r)))
begin (eprogn (rest e) r)
set! (let [[k v] (rest e)] (update! k r (evaluate v r)))
lambda (let [[args & es] (rest e)] (make-function args es r))
;else
(invoke (evaluate (first e) r)
(evlis (rest e) r)))))
(defn eprogn
"Evaluate expressions es sequentially in environment r. Return last value."
[es r]
(if (seq es)
(last (map #(evaluate % r) es))
'()))
(defn evlis
"Evaluate expressions and return list of values."
[as r]
(map #(evaluate % r) as))
(defn invoke
"Function represented as fn that takes a single list argument."
[f args]
(if (fn? f)
(f args)
(wrong "Not a function")))
(defn make-function [variables body env]
(fn [values]
(eprogn body (extend env variables values))))
;; -- the global environment
(def env-global env-init)
(defmacro definitial
([name]
`(do
(swap! env-global #(cons ['~name 'void] %))
'~name))
([name value]
`(do
(swap! env-global #(cons ['~name ~value] %))
'~name)))
(defmacro defprimitive [name value arity]
`(definitial ~name
(fn [values#]
(if (= ~arity (count values#))
(apply ~value values#) ;; clojure's apply
(wrong "Incorrect arity" (list '~name values#))))))
;; These don't hide clojure's own true and false though as they're
;; handled directly be the clojure reader and will pass right through
;; the implicit quoting in the evaluator. (They're not even symbols as
;; they're never exposed to the evaluator as anything other than a
;; boolean.) So it's an approach different again from that of special
;; forms #t and #f which are added to the evaluator at one point in
;; chapter one.
(definitial t true)
(definitial f false)
(definitial nil '())
;; As we have no way of extending the global environment yet.
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
;; Let's provide a more traditional cons cell to the child lisp
;; otherwise clojure's immutability doesn't give us an easy means of
;; providing our lisp with a set-cdr!
(defprotocol MutableCons
(mcar [self])
(mcdr [self])
(mset-car! [self val])
(mset-cdr! [self val]))
;; ...and use some real shonk to get a low-level mutable type.
;; This is as ugly as it looks but we're single-threaded only
;; and this is expressly a toy and nothing more.
(deftype Cell [^{:unsynchronized-mutable true} a ^{:unsynchronized-mutable true} b]
MutableCons
(mcar [self] a)
(mcdr [self] b)
(mset-car! [self val] (set! a val))
(mset-cdr! [self val] (set! b val))
Object
(toString [self] (str "(" a " . " b ")")))
(defn mcons [a b]
(Cell. a b))
;; Expose a few lisp basics
(defprimitive cons mcons 2)
(defprimitive car mcar 1)
(defprimitive cdr mcdr 1)
(defprimitive set-car! mset-car! 2)
(defprimitive set-cdr! mset-cdr! 2)
(defprimitive + + 2)
(defprimitive - - 2)
(defprimitive eq? = 2)
(defprimitive < < 2)
;; And finally a dumb repl...
(defn chapter1-scheme []
(loop []
(print "\n> ")
(flush)
(pr (evaluate (read) env-global))
(flush)
(recur)))
(comment
;; we have mutable cons cells, but printing leaves much to be desired
(set! foo (cons 1 2))
;; => #<Cell (1 . 2)>
(set-cdr! foo (cons 2 nil))
;; => #<Cell (2 . )>
foo
;; => #<Cell (1 . (2 . ))>
;; truthiness is parasitic on the underlying lisp, in clojure 0 is truthy
(if 0 (quote truthy) (quote falsey))
;; => truthy
(begin (set! bar 1) (set! bar 2) bar)
;; => 2
((lambda (x) (+ x 1)) 12)
;; => 13
(set! fib (lambda (x) (if (< x 2) 1 (+ (fib (- x 1)) (fib (- x 2))))))
;; => #<eval$make_function$fn__576 lisp.chapter1.eval$make_function$fn__576@5702cbd3>
(fib 8)
;; => 34
)
;; And a few modifications suggested by exercises...
;; Exercise 1.1
(defn invoke-traced
"Function represented as fn that takes a single list argument."
[f args]
(if (fn? f)
(do
(println "Called with: " args)
(let [ret (f args)]
(println ";=> " ret)
ret))
(wrong "Not a function")))
(defn evaluate-traced
"Evaluate form e in environment r."
[e r]
(if (not (seq? e))
; atom
(if (symbol? e) (lookup e r) e)
; list
(case (first e)
quote (second e)
if (let [[c t f] (rest e)] (if (evaluate c r) (evaluate t r) (evaluate f r)))
begin (eprogn (rest e) r)
set! (let [[k v] (rest e)] (update! k r (evaluate v r)))
lambda (let [[args & es] (rest e)] (make-function args es r))
;else
(invoke-traced (evaluate (first e) r)
(evlis (rest e) r)))))
(defn chapter1-scheme-traced []
(loop []
(print "\n> ")
(flush)
(pr (evaluate-traced (read) env-global))
(flush)
(recur)))
;; NB - this modification requires changes all the way up, through
;; evalute to the repl function which is a limitation of the current
;; design. Clearly the functions themselves could be parameterised
;; but a neater approach is suggested by the common example of
;; an interpreter that's often used in expositions of monads.
;;
;; See "The essence of functional programming" by Wadler
;; for a particularly complete example.
;;
;; http://homepages.inf.ed.ac.uk/wadler/topics/monads.html
(defn -main [& args]
(chapter1-scheme))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment