[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:
Elf M. Sternberg 2015-07-07 19:57:35 -07:00
parent 560bcd4dda
commit bc857b19f1
2 changed files with 119 additions and 43 deletions

View File

@ -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

55
test/test_chapter3.coffee Normal file
View File

@ -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)