[feat] The CPS-based interpreter from Chapter 3 of LiSP, with tests.
This passes all the basic tests provided from Lisp In Small Pieces, chapter 3. This is a functional LiSP interpreter with limited ability and very little bug handling, but it's a solid implementation that matches the specification and passes the tests provided for the CPS interpreter. This commit does *not* provide any of the continuation variants described in the book; it is only the base interpreter.
This commit is contained in:
parent
560bcd4dda
commit
bc857b19f1
|
|
@ -1,11 +1,12 @@
|
|||
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr, setcar} = require "cons-lists/lists"
|
||||
readline = require "readline"
|
||||
{inspect} = require "util"
|
||||
print = require "./print"
|
||||
|
||||
ntype = (node) -> car node
|
||||
nvalu = (node) -> cadr node
|
||||
|
||||
the_false_value = (cons "false", "boolean")
|
||||
|
||||
class Value
|
||||
|
||||
# Represents the base class of a continuation. Calls to invoke resume
|
||||
|
|
@ -18,7 +19,7 @@ class Continuation
|
|||
if nilp cdr v
|
||||
@k.resume (car v)
|
||||
else
|
||||
throw "Continuations expect one argument", [v, env, kont]
|
||||
throw "Continuations expect one argument"
|
||||
|
||||
# Abstract class representing the environment
|
||||
|
||||
|
|
@ -31,8 +32,8 @@ class Environment
|
|||
# class, you have not
|
||||
|
||||
class NullEnv extends Environment
|
||||
lookup: -> throw "Unknown variable"
|
||||
update: -> throw "Unknown variable"
|
||||
lookup: (e) -> throw "Unknown variable #{e}"
|
||||
update: (e) -> throw "Unknown variable #{e}"
|
||||
|
||||
# This appears to be an easy and vaguely abstract handle to the
|
||||
# environment. The book is not clear on the distinction between the
|
||||
|
|
@ -40,6 +41,7 @@ class NullEnv extends Environment
|
|||
|
||||
class FullEnv extends Environment
|
||||
constructor: (@others, @name) ->
|
||||
@_type = "FullEnv"
|
||||
lookup: (name, kont) ->
|
||||
@others.lookup name, kont
|
||||
update: (name, kont, value) ->
|
||||
|
|
@ -52,12 +54,13 @@ class FullEnv extends Environment
|
|||
|
||||
class VariableEnv extends FullEnv
|
||||
constructor: (@others, @name, @value) ->
|
||||
@_type = "VariableEnv"
|
||||
lookup: (name, kont) ->
|
||||
if name == @name
|
||||
kont.resume @value
|
||||
else
|
||||
@others.lookup name, kont
|
||||
update: (nam, kont, value) ->
|
||||
update: (name, kont, value) ->
|
||||
if name == @name
|
||||
@value = value
|
||||
kont.resume value
|
||||
|
|
@ -76,11 +79,13 @@ evaluateQuote = (v, env, kont) ->
|
|||
# true or false branch, again in the current enviornment.
|
||||
|
||||
evaluateIf = (exps, env, kont) ->
|
||||
evaluate (car e), env, new IfCont(kont, (cadr e), (caddr e), env)
|
||||
evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
|
||||
|
||||
class IfCont extends Continuation
|
||||
constructor: (@k, @ift, @iff, @env) ->
|
||||
resume: (v) -> evaluate (if v then @ift else @iff), @env, @k
|
||||
@_type = "IfCont"
|
||||
resume: (value) ->
|
||||
evaluate (if value == the_false_value then @iff else @ift), @env, @k
|
||||
|
||||
# Sequences: evaluates the current expression with a continuation that
|
||||
# represents "the next expression" in the sequence. Upon resumption,
|
||||
|
|
@ -97,6 +102,7 @@ evaluateBegin = (exps, env, kont) ->
|
|||
|
||||
class BeginCont extends Continuation
|
||||
constructor: (@k, @exps, @env) ->
|
||||
@_type = "BeginCont"
|
||||
resume: (v) -> evaluateBegin (cdr @exps), @env, @k
|
||||
|
||||
# In this continuation, we simply pass the continuation and the name
|
||||
|
|
@ -110,12 +116,13 @@ evaluateVariable = (name, env, kont) ->
|
|||
# called after an update has been performed.
|
||||
|
||||
evaluateSet = (name, exp, env, kont) ->
|
||||
evaluate exp, env, (new setCont(kont, name, env))
|
||||
evaluate exp, env, (new SetCont(kont, name, env))
|
||||
|
||||
class SetCont extend Continuation
|
||||
class SetCont extends Continuation
|
||||
constructor: (@k, @name, @env) ->
|
||||
@_type = "SetCont"
|
||||
resume: (value) ->
|
||||
update @env, @name, @k, value
|
||||
@env.update @name, @k, value
|
||||
|
||||
# Calls the current contunation, passing it a new function wrapper.
|
||||
|
||||
|
|
@ -131,6 +138,7 @@ evaluateLambda = (names, exp, env, kont) ->
|
|||
|
||||
class Function extends Value
|
||||
constructor: (@variables, @body, @env) ->
|
||||
@_type = "Function"
|
||||
invoke: (values, env, kont) ->
|
||||
evaluateBegin @body, (extend @env, @variables, values), kont
|
||||
|
||||
|
|
@ -139,7 +147,7 @@ class Function extends Value
|
|||
|
||||
extend = (env, names, values) ->
|
||||
if (pairp names) and (pairp values)
|
||||
new VariableEnv (extend env (cdr names) (cdr values)), (car names), (car values)
|
||||
new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
|
||||
else if (nilp names)
|
||||
if (nilp values) then env else throw "Arity mismatch"
|
||||
else
|
||||
|
|
@ -158,8 +166,9 @@ evaluateApplication = (exp, exps, env, kont) ->
|
|||
|
||||
class EvFunCont extends Continuation
|
||||
constructor: (@k, @exp, @env) ->
|
||||
@_type = "EvFunCont"
|
||||
resume: (f) ->
|
||||
evaluateArguments (@exp, @k, new ApplyCont @k, f, @env)
|
||||
evaluateArguments @exp, @env, (new ApplyCont(@k, f, @env))
|
||||
|
||||
# Evaluate the first list, creating a new list of the arguments. Upon
|
||||
# completion, resume the continuation with the gather phase
|
||||
|
|
@ -168,18 +177,20 @@ evaluateArguments = (exp, env, kont) ->
|
|||
if (pairp exp)
|
||||
evaluate (car exp), env, (new ArgumentCont kont, exp, env)
|
||||
else
|
||||
kont.resume("No more arguments")
|
||||
kont.resume(nil)
|
||||
|
||||
class ArgumentCont extends Continuation
|
||||
constructor: (@k, @exp, @env) ->
|
||||
@_type = "ArgumentCont"
|
||||
resume: (v) ->
|
||||
evaluateArguments (cdr @env, @env, new GatherCont @k, v)
|
||||
evaluateArguments (cdr @exp), @env, (new GatherCont @k, v)
|
||||
|
||||
# Gather the arguments as each ArgumentCont is resumed into a list to
|
||||
# be passed to our next step.
|
||||
|
||||
class GatherCont extends Continuation
|
||||
constructor: (@k, @v) ->
|
||||
@_type = "GatherCont"
|
||||
resume: (v) ->
|
||||
@k.resume (cons @v, v)
|
||||
|
||||
|
|
@ -187,28 +198,40 @@ class GatherCont extends Continuation
|
|||
|
||||
class ApplyCont extends Continuation
|
||||
constructor: (@k, @fn, @env) ->
|
||||
@_type = "ApplyCont"
|
||||
resume: (v) ->
|
||||
invoke @fn, v, @env, @k
|
||||
console.log
|
||||
@fn.invoke v, @env, @k
|
||||
|
||||
# A special continuation that represents what we want the interpreter
|
||||
# to do when it's done processing.
|
||||
|
||||
class BottomCont extends Continuation
|
||||
constructor: (@k, @f) ->
|
||||
@_type = "BottomCont"
|
||||
resume: (v) ->
|
||||
@f(v)
|
||||
|
||||
class Primitive extends Value
|
||||
constructor: (@name, @nativ) ->
|
||||
@_type = "Primitive"
|
||||
invoke: (args, env, kont) ->
|
||||
@nativ.apply null, (listToVector args), env, kont
|
||||
@nativ.apply null, [args, env, kont]
|
||||
|
||||
astSymbolsToLispSymbols = (node) ->
|
||||
return nil if nilp node
|
||||
throw "Not a list of variable names" if not (ntype(node) is 'list')
|
||||
handler = (node) ->
|
||||
return nil if nilp node
|
||||
cons (nvalu car node), (handler cdr node)
|
||||
handler(nvalu node)
|
||||
|
||||
evaluate = (e, env, kont) ->
|
||||
[type, exp] = [(ntype e), (nvalu e)]
|
||||
if type == "symbol"
|
||||
return evaluateVariable exp, env, kont
|
||||
if type in ["number", "string", "boolean", "vector"]
|
||||
return exp
|
||||
return kont.resume exp
|
||||
if type == "list"
|
||||
head = car exp
|
||||
if (ntype head) == 'symbol'
|
||||
|
|
@ -216,13 +239,15 @@ evaluate = (e, env, kont) ->
|
|||
when "quote" then evaluateQuote (cdr exp), env, kont
|
||||
when "if" then evaluateIf (cdr exp), env, kont
|
||||
when "begin" then evaluateBegin (cdr exp), env, kont
|
||||
when "set!" then evaluateSet (nvalu cadr exp), (nvalu caddr exp), env, kont
|
||||
when "set!" then evaluateSet (nvalu cadr exp), (caddr exp), env, kont
|
||||
when "lambda" then evaluateLambda (astSymbolsToLispSymbols cadr exp), (cddr exp), env, kont
|
||||
evaluateApplication (car exp), (cdr exp), env, cont
|
||||
else evaluateApplication (car exp), (cdr exp), env, kont
|
||||
else
|
||||
evaluateApplication (car exp), (cdr exp), env, cont
|
||||
evaluateApplication (car exp), (cdr exp), env, kont
|
||||
else
|
||||
throw new Error("Can't handle a #{type}")
|
||||
throw new Error("Can't handle a '#{type}'")
|
||||
|
||||
env_init = new NullEnv()
|
||||
|
||||
definitial = (name, value = nil) ->
|
||||
env_init = new VariableEnv env_init, name, value
|
||||
|
|
@ -234,13 +259,11 @@ defprimitive = (name, nativ, arity) ->
|
|||
if (vmargs.length == arity)
|
||||
kont.resume (nativ.apply null, vmargs)
|
||||
else
|
||||
throw "Incorrect arity")
|
||||
throw "Incorrect arity"
|
||||
|
||||
defpredicate = (name, nativ, arity) ->
|
||||
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
|
||||
|
||||
the_false_value = (cons "false", "boolean")
|
||||
|
||||
definitial "#t", true
|
||||
definitial "#f", the_false_value
|
||||
definitial "nil", nil
|
||||
|
|
@ -263,30 +286,28 @@ defpredicate "gt", ((a, b) -> a > b), 2
|
|||
defpredicate "lte", ((a, b) -> a <= b), 2
|
||||
defpredicate "gte", ((a, b) -> a >= b), 2
|
||||
defpredicate "eq?", ((a, b) -> a == b), 2
|
||||
defpredicate "pair?" ((a) -> pairp a), 1
|
||||
defpredicate "nil?" ((a) -> nilp a), 1
|
||||
defpredicate "symbol?" ((a) -> /\-?[0-9]+$/.test(a) == false), 1
|
||||
defpredicate "pair?", ((a) -> pairp a), 1
|
||||
defpredicate "nil?", ((a) -> nilp a), 1
|
||||
defpredicate "symbol?", ((a) -> /\-?[0-9]+$/.test(a) == false), 1
|
||||
|
||||
definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
|
||||
if nilp cdr values
|
||||
(car values).invoke (cons kont), env, kont
|
||||
else
|
||||
throw "Incorrect arity for call/cc", [r, k]
|
||||
throw ["Incorrect arity for call/cc", [r, k]]
|
||||
|
||||
definitial "apply", new Primitive "apply", (values, env, kont) ->
|
||||
if pairp cdr values
|
||||
f = car values
|
||||
args = (() ->
|
||||
(flat = (args) ->
|
||||
if nilp cdr args then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
|
||||
if nilp (cdr args) then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
|
||||
f.invoke args, env, kont
|
||||
|
||||
definitial "list", new Primitive "list", (values, env, kont) ->
|
||||
(values, env, kont) -> kont.resume(values)
|
||||
|
||||
env_init = new NullEnv()
|
||||
|
||||
interpreter = (ast, kont) ->
|
||||
evaluate ast, env_init, new BottomCont null, kont
|
||||
|
||||
module.exports = intepreter
|
||||
module.exports = interpreter
|
||||
|
|
|
|||
|
|
@ -0,0 +1,55 @@
|
|||
chai = require 'chai'
|
||||
chai.should()
|
||||
expect = chai.expect
|
||||
|
||||
{cons} = require "cons-lists/lists"
|
||||
olisp = require '../chapter3/interpreter'
|
||||
{read, readForms} = require '../chapter1/reader'
|
||||
|
||||
the_false_value = (cons "false", "boolean")
|
||||
|
||||
lisp = (ast) ->
|
||||
ret = undefined
|
||||
olisp ast, (i) -> ret = i
|
||||
return ret
|
||||
|
||||
|
||||
describe "Core interpreter #3", ->
|
||||
it "Should handle true statements", ->
|
||||
expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
|
||||
it "Should handle false statements", ->
|
||||
expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
|
||||
it "Should handle return strings", ->
|
||||
expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
|
||||
it "Should handle return strings when false", ->
|
||||
expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
|
||||
it "Should handle equivalent objects that are not intrinsically truthy", ->
|
||||
expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
|
||||
it "Should handle inequivalent objects that are not intrinsically truthy", ->
|
||||
expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
|
||||
|
||||
it "Should handle basic arithmetic", ->
|
||||
expect(lisp read '(begin (+ 5 5))').to.equal(10)
|
||||
expect(lisp read '(begin (* 5 5))').to.equal(25)
|
||||
expect(lisp read '(begin (/ 5 5))').to.equal(1)
|
||||
expect(lisp read '(begin (- 9 5))').to.equal(4)
|
||||
|
||||
it "Should handle some algebra", ->
|
||||
expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
|
||||
|
||||
it "Should handle a basic setting", ->
|
||||
expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
|
||||
|
||||
it "Should handle a zero arity thunk", ->
|
||||
expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
|
||||
|
||||
it "Should handle a two arity thunk", ->
|
||||
expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
|
||||
|
||||
it "Should handle a recursive function", ->
|
||||
expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
|
||||
|
||||
it "Should handle an IIFE", ->
|
||||
expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue