Create a gist now

Instantly share code, notes, and snippets.

@gmorpheme /cont.clj
Last active Aug 29, 2015

What would you like to do?
Translation of Chapter 3 of Lisp in Small Pieces into Clojure
(ns ^{:doc "Loose translation of evaluator from chapter three
of Lisp in Small Pieces into Clojure."}
(:refer-clojure :exclude [invoke])
(:require [clojure.test :refer [deftest is]]))
(declare evaluate wrong)
(defn wrong [& args]
(println args)
(throw (RuntimeException. (first args))))
;; Rather than protocol for Invokable which would need specialising
;; for every continuation type, let's use multimethod instead.
(defmulti invoke
"Unified invocation interface for functions and continuations"
(fn [target args r k] (type target)))
;; Chapter 3 uses a simple object system with
;; implementation inheritance, in particular the wrapped continuation
;; is provided by the base class and made available to subclasses.
;; We'll forego this convenience in favour of a more idiomatic
;; protocol / record separation for continuations.
(defprotocol Environment
"A CPS-based environment protocol. Environments now yield up their
values to continuations instead of returning them."
(lookup [self n k])
(update! [self n k v]))
(defprotocol Continuation
"Continuations are resumed by passing them the result of the
previous expression."
(resume [self value]))
;; For continuations, invoke is a wordy synonym for resume:
(defmethod invoke lispic.chapter3.cont.Continuation [target args r k]
(resume target (first args)))
;;; The basic evaluation implementation
;; This, the simplest evaluation function, makes the workings of CPS
;; pretty clear. Where previous evaluators would simply v directly,
;; the CPS implementation passes it into the resumption of the current
;; continuation.
(defn evaluate-quote
"Simply forward the value to the continuation."
[v r k]
(resume k v))
;; For anything more complicated we need to decompose the processing
;; into separate steps, the later steps are represented as instances
;; of Continuation that wrap around to the current continuation so
;; as to be invoked once the current evaluation step has completed.
;; For instance, this continuation represents the step of receiving
;; the value of the condition and selecting which branch to run. In
;; sequence it clearly happens after the evaluation of the condition
;; expression and therefore is wrapped in a continuation for the
;; evaluation of that expression.
(defrecord SelectBranchContinuation [k et ef r]
(resume [self v]
(evaluate (if v et ef) r k))) ; qq truthiness?
(defn evaluate-if
"Evaluate if expression."
[ec et ef r k]
(evaluate ec r (SelectBranchContinuation. k et ef r)))
;; A sequence of expressions corresponds to a nested set of
;; continuations each of which represents the rest of the sequence
;; after the expression currently being evaluated.
(declare evaluate-begin)
(defrecord BeginContinuation [k e* r]
(resume [self v]
(evaluate-begin (rest e*) r k)))
;; Note the oddity wherein it is the continuation resume itself that
;; selects the `rest` of the expressions to evaluate. This is faithful
;; to the book which claims it helps debugging.
(defn evaluate-begin
"Evaluate a begin form. (begin) evaluates to nil."
[e* r k]
(if (seq e*)
(if (seq (rest e*))
(evaluate (first e*) r (BeginContinuation. k e* r))
(evaluate (first e*) r k))
(resume k nil)))
;;; Implementations of Environment.
(defrecord NullEnvironment []
(lookup [self n k]
(wrong "Unknown variable" n self k))
(update! [self n k v]
(wrong "Unknown variable" n self k)))
;; In the book this is "full" environment, but it is anything but! It
;; is a name with no value.
;; So "full" and "variable" I have replaced by declaration and
;; definition.
(defrecord DeclarationEnvironment [others name]
(lookup [self n k]
(lookup others n k))
(update! [self n k v]
(update! others n k v)))
;; DefinitionEnvironment allows for mutation of value by requiring
;; that it is an atom.
(defrecord DefinitionEnvironment [others name value]
(lookup [self n k]
(if (= n name)
(resume k @value)
(lookup others n k)))
(update! [self n k v]
(if (= n name)
(swap! value (constantly v))
(resume k v)))))
(defn add-definition
"Create new environment with binding of name to value. Value must be
[env name value]
{:pre [(instance? clojure.lang.Atom value)]}
(DefinitionEnvironment. env name value))
;; No extra continuations are required for evaluating variables. It's
;; a simple one-step process.
(defn evaluate-variable
"Evaluate a variable and yield result to k"
[n r k]
(lookup r n k))
;; Set expressions need an intermediate continuation for the step of
;; setting the value after the step of evaluating the value to be set.
(defrecord SetContinuation [k n r]
(resume [self v]
(update! r n k v)))
(defn evaluate-set! [n e r k]
(evaluate e r (SetContinuation. k n r)))
;; functions
(declare extend-env)
;; Function representation
(defrecord Function [variables body env])
;; What it means to invoke a function
(defmethod invoke Function [target v* r k]
(let [env (extend-env (:env target) (:variables target) v*)]
(evaluate-begin (:body target) env k)))
(defn evaluate-lambda
"Evaluate lambda expression."
[n* e* r k]
(resume k (Function. n* e* r)))
(defn extend-env
"Extend environment with seqs of corresponding names and
values. Convenient API for functions for binding argument lists."
[env names values]
(and (seq names) (seq values))
(add-definition (extend-env env (rest names) (rest values))
(first names)
(atom (first values)))
(and (nil? (seq names)) (nil? (seq values)))
(symbol? names)
(add-definition env names (atom values))
(wrong "Arity mismatch")))
;; Function application requires several steps and therefore several
;; implementations of Continuation.
(declare evaluate-arguments invoke)
;; finally applies the function once it is fully understood
(defrecord ApplyContinuation [k f r]
(resume [self v]
(invoke f v r k)))
;; evaluate the function prior to application - expands into
;; successive cycles of arg & gather continuations
(defrecord EvFunContinuation [k e* r]
(resume [self f]
(evaluate-arguments e* r (ApplyContinuation. k f r))))
;; gather the arguments into a list
(defrecord GatherContinuation [k v]
(resume [self v*]
(resume k (cons v v*))))
;; evaluate the function arguments (recursing indirectly)
(defrecord ArgumentContinuation [k e* r]
(resume [self v]
(evaluate-arguments (rest e*) r (GatherContinuation. k v))))
;; evaluate the function arguments (recursing indirectly)
(defn evaluate-arguments [e* r k]
(if (seq e*)
(evaluate (first e*) r (ArgumentContinuation. k e* r))
(resume k [])))
(defn evaluate-application [e e* r k]
(evaluate e r (EvFunContinuation. k e* r)))
;; initial environment
(def r-init (NullEnvironment.))
(defmacro definitial
"Define a global."
`(definitial '~name 'void))
([name value]
(constantly (DefinitionEnvironment. r-init '~name (atom ~value))))
;; Primitive represents primitively defined functions (cons, car, cdr etc.)
(defrecord Primitive [name address])
;; Invoking a Primitive is just using the Clojure implementation (":address")
(defmethod invoke Primitive [target v* r k]
((:address target) v* r k))
(defmacro defprimitive
"Define a global function using a Clojure implementation which
accepts args, env and continuation. Exposing continuation here
allows us to implement call/cc. "
[name value arity]
`(definitial ~name
(Primitive. '~name (fn [v*# r# k#]
(if (= (count v*#) ~arity)
(resume k# (apply ~value v*#))
(wrong "Incorrect ~arity" v*#))))))
(defprotocol MutableCons
(mcar [self])
(mcdr [self])
(mset-car! [self val])
(mset-cdr! [self val]))
;; Yet another implementation of mutable cons cells, this one probably
;; the most awkward yet.
(deftype AtomCons [car cdr]
(mcar [_] @car)
(mcdr [_] @cdr)
(mset-car! [_ val]
(reset! car val))
(mset-cdr! [_ val]
(reset! cdr val)))
(defn mcons [a b]
(AtomCons. (atom a) (atom b)))
(defn unwrap
"For inspecting values of AtomCons cells."
(when atom-cons
(cons (mcar atom-cons) (unwrap (mcdr atom-cons)))))
(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)
;; As well as initial environment, we need a "top-level" continuation.
(defrecord BottomContinuation [f]
(resume [self v]
(f v)))
(def k-init (BottomContinuation. identity))
;;; Now we can implement some of the various control structures
;;; detailed in chapter 3.
;;; call/cc - actually the simplest to provide, simply exposes the
;;; continuation
(definitial call-cc
(Primitive. 'call-cc (fn [v* r k]
(if (= 1 (count v*))
(invoke (first v*) [k] r k)
(wrong "Incorrect arity: " 'call-cc v*)))))
;;; Catch / Throw implementation
;;; This provides catch / throw as primitives via the evaluate-catch
;;; and evaluate-throw methods.
;;; Unlike block / return-from, catch / throw uses unevaluated symbols
;;; to identify the escape
(defrecord LabelledContinuation [k tag]
(resume [self v]
(resume k v)))
(defrecord CatchContinuation [k body r]
(resume [self v]
(evaluate-begin body r (LabelledContinuation. k v))))
;; Looks superfluous but note that the continuation that is resumed is
;; not k but success-k. k is used as the default continuation and
;; followed when searching down through the continuation stack for
;; labels. Until the computation has actually succeeded and passes a
;; value to success-k, the current continuation is the one at the
;; throw point. So another throw in the throw form has the same set of
;; catches visible.
;; Could have made this more obvious by adding catch-lookup as a
;; protocol and implementations throughout.
(defrecord ThrowingContinuation [k tag success-k]
(resume [self v]
(resume success-k v)))
(defmulti catch-lookup
"Find a LabelledContinuation with the specified tag evaluate the
throw expression in the context of it."
(fn [k tag throw-k] (type k)))
;; catch-lookup is specialised for ThrowContinuatoin so that it will
;; ultimately evaluate form in environment r
(defrecord ThrowContinuation [k form r]
(resume [self tag]
(catch-lookup self tag self)))
(defn evaluate-catch [e* r k]
(evaluate (first e*) r (CatchContinuation. k (rest e*) r)))
(defmethod catch-lookup LabelledContinuation [k tag throw-k]
(if (= tag (:tag k))
(evaluate (:form throw-k)
(:r throw-k)
(ThrowingContinuation. throw-k tag k))
(catch-lookup (:k k) tag throw-k)))
(defmethod catch-lookup :default [k tag throw-k]
(catch-lookup (:k k) tag throw-k))
(defmethod catch-lookup BottomContinuation [k tag throw-k]
(wrong "No associated catch"))
(defn evaluate-throw [tag form r k]
(evaluate tag r (ThrowContinuation. k form r)))
;;; Test block / return-from
;;; Main differences: escapes are looked up lexically so they're
;;; stored in a new type of environment and unlike catch / throw,
;;; they're not evaluated prior to matching.
(defrecord BlockContinuation [k label]
(resume [self v]
(resume k v)))
(defmulti unwind
"Search through the continuation chain starting at k to find
ktarget, resuming with v if found. Fail otherwise."
(fn [k v ktarget] (type k)))
(defmethod unwind :default [k v ktarget]
(if (= k ktarget)
(resume k v)
(unwind (:k k) v ktarget)))
(defmethod unwind BottomContinuation [k v target]
(wrong "Obsolete continuation: " v))
;; The various elements needed to use the environment to bind
;; names to continuations
(defprotocol BlockLookup
(block-lookup [self label k v]
"Check the environment maps label to continuation k and then pass v to it."))
(defrecord BlockEnvironment [others label cont]
(lookup [self n k]
(lookup others n k))
(update! [self n k v]
(update! others n k v))
(block-lookup [self n k v]
(if (= n label)
(unwind k v cont)
(block-lookup others n k v))))
(def ^:private pass-through {:block-lookup (fn [self n k v] (block-lookup (:others self) n k v))})
(extend DeclarationEnvironment BlockLookup pass-through)
(extend DefinitionEnvironment BlockLookup pass-through)
(extend-type NullEnvironment
(block-lookup [self n k v]
(wrong "Unknown block label: " n)))
(defn evaluate-block
"Evaluate block form"
[label body r k]
(let [k (BlockContinuation. k label)]
(evaluate-begin body
(BlockEnvironment. r label k)
(defrecord ReturnFromContinuation [k r label]
(resume [k v]
(block-lookup r label k v)))
(defn evaluate-return-from
"Evaluate the return form then pass into return-from continuation."
[label form r k]
(evaluate form r (ReturnFromContinuation. k r label)))
;;; Put it all together in a new version of the interpreter
(defn evaluate
"Evaluate with all the trimmings"
(evaluate e r-init k-init))
([e r k]
(if (not (coll? e))
(if (symbol? e)
(evaluate-variable e r k)
(evaluate-quote e r k))
(let [[x & args] e]
(case x
;; the normal stuff, no let this time
quote (evaluate-quote x r k)
if (evaluate-if x (first args) (second args) r k)
begin (evaluate-begin args r k)
set! (evaluate-set! (first args) (second args) r k)
lambda (evaluate-lambda (first args) (rest args) r k)
;; wire in catch / throw
catch (evaluate-catch args r k)
throw (evaluate-throw (first args) (second args) r k)
;; wire in block / return-from
block (evaluate-block (first args) (rest args) r k)
return-from (evaluate-return-from (first args) (second args) r k)
(evaluate-application x args r k))))))
;; This time round, let's illustrate usage by writing some tests
;; inline...
(deftest test-basic
(is (= (evaluate '(+ 2 3)) 5))
(is (= (evaluate '((lambda (x y) (+ x y)) 2 3)) 5))
(is (= (evaluate '((lambda (x y) (begin x y (+ x y))) 2 3)) 5))
(is (= (unwrap (evaluate '(cons 9 (cons 10 nil)))) '(9 10))))
(deftest test-call-cc
(is (= (evaluate '(+ 5 (call-cc (lambda (k) (k 7))))) 12))
(is (= (evaluate '(call-cc (lambda (k) (* 120 (+ 22 (k 44)))))) 44)))
(deftest test-catch-throw
(is (= (evaluate '(catch (quote a) 1 2 3 4 (throw (quote a) 100) 5 6 7))) 100)
(is (= (evaluate '(catch (quote x) 99)) 99))
(is (= (evaluate '(catch (quote x) ((lambda (x y) (+ x y)) 2 3))) 5))
(is (= (evaluate '(catch (quote y)
((lambda (x y) x y (throw (quote y) (+ x y)) x y) 2 3))) 5))
(is (= (evaluate '(catch 2
(* 7 (catch 1
(* 3 (catch 2
(throw 1 (throw 2 5)))))))) (* 7 3 5)))
(is (thrown? RuntimeException
(evaluate '( (lambda (x y) (catch (quote dynamic) (* x y))) 6 (throw (quote dynamic) 20) ))))
;; this illustrates the different behaviour between dynamic and
;; lexical escapes:
(is (= (evaluate '( (lambda (f) (catch (quote dynamic) (f))) (lambda () (throw (quote dynamic) 20)) ))
(deftest test-block-and-return-from
(is (= (evaluate '(block a 1 2 3 4 (return-from a 100) 5 6 7))) 100)
(is (= (evaluate '(block x 99)) 99))
(is (= (evaluate '(block x ((lambda (x y) (+ x y)) 2 3))) 5))
(is (= (evaluate '(block y
((lambda (x y) x y (return-from y (+ x y)) x y) 2 3))) 5))
(is (= (evaluate '(block 2
(* 7 (block 1
(* 3 (block 2
(return-from 1 (return-from 2 5)))))))) (* 7 3 5)))
(is (thrown? RuntimeException
(evaluate '( (lambda (x y) (block lexical (* x y))) 6 (return-from lexical 20) ))))
;; this illustrates the different behaviour between dynamic and
;; lexical escapes:
(is (thrown? RuntimeException
(evaluate '( (lambda (f) (block lexical (f))) (lambda () (return-from lexical 20)) )))))

bloat commented Feb 28, 2015

Your's looks interesting. I was 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