[feat] New interpreter needed for throwing context changes.

This commit is contained in:
Elf M. Sternberg 2015-07-31 07:48:42 -07:00
parent 3e17e69746
commit 32edb45f84
3 changed files with 525 additions and 0 deletions

View File

@ -0,0 +1,458 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Symbol} = require '../chapter1/reader_types'
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
# Base class that represents a value. Base class representing a LiSP
# value, a primitive, or a function
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
class Value
# Represents the base class of a continuation. Calls to invoke resume
# the contained continuation, which is typecast to one of the specific
# continuation needs of conditional, sequence, etc...
class Continuation
constructor: (@kont) ->
invoke: (value, env, kont) ->
if nilp cdr value
@kont.resume (car value)
else
throw new LispInterpreterError "Continuations expect one argument"
unwind: (value, ktarget) ->
if (@kont == ktarget) then (@kont.resume value) else (@kont.unwind value, ktarget)
catchLookup: (tag, kk) ->
@kont.catchLookup tag, kk
# Abstract class representing the environment
class Environment
lookup: -> throw new LispInterpreterError "Nonspecific invocation"
update: -> throw new LispInterpreterError "Nonspecific invocation"
blockLookup: -> throw new LispInterpreterError "Not an Environment"
# Base of the environment stack. If you hit this, your variable was
# never found for lookup/update. Note that at this time in the
# class, you have not
class NullEnv extends Environment
lookup: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
update: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
blockLookup: (name) -> throw new LispInterpreterError "Unknown block label #{name}"
# This appears to be an easy and vaguely abstract handle to the
# environment. The book is not clear on the distinction between the
# FullEnv and the VariableEnv.
class FullEnv extends Environment
constructor: (@others, @name) ->
@_type = "FullEnv"
lookup: (name, kont) ->
@others.lookup name, kont
update: (name, kont, value) ->
@others.update name, kont, value
blockLookup: (name, kont, value) ->
@others.blockLookup(name, kont, value)
# This is the classic environment pair; either it's *this*
# environment, or it's a parent environment, until you hit the
# NullEnv. Once the name has been found, the continuation is called
# with the found value.
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: (name, kont, value) ->
if name == @name
@value = value
kont.resume value
else
@others.update name, kont, value
# "Renders the quote term to the current continuation"; in a more
# familiar parlance, calls resume in the current context with the
# quoted term uninterpreted.
evaluateQuote = (v, env, kont) ->
kont.resume normalizeForms v
# Evaluates the conditional expression, creating a continuation with
# the current environment that, when resumed, evaluates either the
# true or false branch, again in the current enviornment.
evaluateIf = (exps, env, kont) ->
evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
class IfCont extends Continuation
constructor: (@kont, @ift, @iff, @env) ->
@_type = "IfCont"
resume: (value) ->
evaluate (if value == the_false_value then @iff else @ift), @env, @kont
# Sequences: evaluates the current expression with a continuation that
# represents "the next expression" in the sequence. Upon resumption,
# calls this function with that next expression.
evaluateBegin = (exps, env, kont) ->
if (pairp exps)
if pairp (cdr exps)
evaluate (car exps), env, (new BeginCont kont, exps, env)
else
evaluate (car exps), env, kont
else
kont.resume("Begin empty value")
class BeginCont extends Continuation
constructor: (@kont, @exps, @env) ->
@_type = "BeginCont"
resume: (v) -> evaluateBegin (cdr @exps), @env, @kont
# In this continuation, we simply pass the continuation and the name
# to the environment to look up. The environment knows to call the
# continuation with the value.
evaluateVariable = (name, env, kont) ->
env.lookup(name, kont)
# This is the same dance as lookup, only with the continuation being
# called after an update has been performed.
evaluateSet = (name, exp, env, kont) ->
evaluate exp, env, (new SetCont(kont, name, env))
class SetCont extends Continuation
constructor: (@kont, @name, @env) ->
@_type = "SetCont"
resume: (value) ->
@env.update @name, @kont, value
# Calls the current contunation, passing it a new function wrapper.
evaluateLambda = (names, exp, env, kont) ->
kont.resume new Function names, exp, env
# Upon invocation, evaluates the body with a new environment that
# consists of the original names, their current values as called, and
# the continuation an the moment of invocation, which will continue
# (resume) execution once the function is finished.
#
# By the way: this is pretty much the whole the point.
class Function extends Value
constructor: (@variables, @body, @env) ->
@_type = "Function"
invoke: (values, env, kont) ->
evaluateBegin @body, (extend @env, @variables, values), kont
# Helper function to build name/value pairs for the current execution
# context.
extend = (env, names, values) ->
if (pairp names) and (pairp values)
new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
else if (nilp names)
if (nilp values) then env else throw new LispInterpreterError "Arity mismatch"
else
new VariableEnv env, names, values
# Now we start the invocation: this is applying the function. Let's
# take it stepwise.
# Create a function environment. Calls the evaluateArguments(), which
# in turns goes down the list of arguments and creates a new
# environment, and then the continuation is to actually appy the nev
# environment to the existing function.
evaluateApplication = (exp, exps, env, kont) ->
evaluate exp, env, (new EvFunCont kont, exps, env)
class EvFunCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "EvFunCont"
resume: (f) ->
evaluateArguments @exp, @env, (new ApplyCont(@kont, f, @env))
# Evaluate the first list, creating a new list of the arguments. Upon
# completion, resume the continuation with the gather phase
evaluateArguments = (exp, env, kont) ->
if (pairp exp)
evaluate (car exp), env, (new ArgumentCont kont, exp, env)
else
kont.resume(nil)
class ArgumentCont extends Continuation
constructor: (@kont, @exp, @env) ->
@_type = "ArgumentCont"
resume: (v) ->
evaluateArguments (cdr @exp), @env, (new GatherCont @kont, v)
# Gather the arguments as each ArgumentCont is resumed into a list to
# be passed to our next step.
class GatherCont extends Continuation
constructor: (@kont, @value) ->
@_type = "GatherCont"
resume: (value) ->
@kont.resume (cons @value, value)
# Upon resumption, invoke the function.
class ApplyCont extends Continuation
constructor: (@kont, @fn, @env) ->
@_type = "ApplyCont"
resume: (value) ->
@fn.invoke value, @env, @kont
# A special continuation that represents what we want the interpreter
# to do when it's done processing.
class BottomCont extends Continuation
constructor: (@kont, @func) ->
@_type = "BottomCont"
resume: (value) ->
@func(value)
unwind: (value, ktarget) ->
throw new LispInterpreterError "Obsolete continuation"
catchLookup: (tag, kk) ->
throw new LispInterpreterError "No associated catch"
evaluateBlock = (label, body, env, kont) ->
k = new BlockCont(kont, label)
evaluateBegin body, (new BlockEnv env, label, kont), k
class BlockCont extends Continuation
constructor: (@kont, @label) ->
@_type = "BlockCont"
resume: (value) ->
@kont.resume value
class BlockEnv extends FullEnv
constructor: (@others, @name, @kont) ->
blockLookup: (name, kont, value) ->
if (name == @name)
kont.unwind value, @kont
else
@others.blockLookup(name, kont, value)
evaluateReturnFrom = (label, form, env, kont) ->
evaluate form, env, (new ReturnFromCont kont, env, label)
class ReturnFromCont extends Continuation
constructor: (@kont, @env, @label) ->
resume: (v) ->
@env.blockLookup @label, @kont, v
evaluateCatch = (tag, body, env, kont) ->
evaluate tag, env, (new CatchCont kont, body, env)
class CatchCont extends Continuation
constructor: (@kont, @body, @env) ->
resume: (value) ->
evaluateBegin @body, @env, (new LabeledCont @kont, value)
class LabeledCont extends Continuation
constructor: (@kont, @tag) ->
resume: (value) ->
@kont.resume value
catchLookup: (tag, kk) ->
if eq tag, @tag
evaluate kk.form, kk.env, (new ThrowingCont kk, tag, this)
else
@kont.catchLookup tag, kk
class ThrowCont extends Continuation
constructor: (@kont, @form, @env) ->
resume: (value) ->
@catchLookup value, @
evaluateThrow = (tag, form, env, kont) ->
evaluate tag, env, (new ThrowCont kont, form, env)
class UnwindCont extends Continuation
constructor: (@kont, @value, @target) ->
class ThrowingCont extends Continuation
constructor: (@kont, @tag, @resumecont) ->
resume: (value) ->
@kont.unwind @resumecont.resume value
evaluateUnwindProtect = (form, cleanup, env, kont) ->
evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
class UnwindProtectCont extends Continuation
constructor: (@kont, @cleanup, @env) ->
resume: (value) ->
evaluateBegin @cleanup, @env, (new ProtectReturnCont @kont, value)
unwind: (value, target) ->
evaluateBegin @cleanup, @env, (new UnwindCont @kont, value, target)
class ProtectReturnCont extends Continuation
constructor: (@kont, @value) ->
resume: (value) ->
@kont.resume @value
class Primitive extends Value
constructor: (@name, @nativ) ->
@_type = "Primitive"
invoke: (args, env, kont) ->
@nativ.apply null, [args, env, kont]
env_init = new NullEnv()
definitial = (name, value = nil) ->
env_init = new VariableEnv env_init, name, value
name
defprimitive = (name, nativ, arity) ->
definitial name, new Primitive name, (args, env, kont) ->
vmargs = listToVector(args)
if (vmargs.length == arity)
kont.resume (nativ.apply null, vmargs)
else
throw new LispInterpreterError "Incorrect arity"
defpredicate = (name, nativ, arity) ->
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
definitial "#t", true
definitial "#f", the_false_value
definitial "nil", nil
# FIXME: All of these things dereference to the same value!!!!
for i in [
"x", "y", "z", "a", "b", "c", "foo", "bar", "hux",
"fib", "fact", "visit", "primes", "length"]
definitial i
defprimitive "cons", cons, 2
defprimitive "car", car, 2
defprimitive "cdr", cdr, 2
defprimitive "set-cdr!", setcdr, 2
defprimitive "set-car!", setcar, 2
defprimitive "+", ((a, b) -> a + b), 2
defprimitive "*", ((a, b) -> a * b), 2
defprimitive "-", ((a, b) -> a - b), 2
defprimitive "/", ((a, b) -> a / b), 2
defpredicate "lt", ((a, b) -> a < b), 2
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
definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
if nilp cdr values
(car values).invoke (cons kont), env, kont
else
throw new LispInterpreterError "Incorrect arity for call/cc"
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))()
f.invoke args, env, kont
definitial "funcall", new Primitive "funcall", (args, env, kont) ->
if not nilp cdr args
@kont.invoke (car args), (cdr args)
else
throw new LispInterpreterError "Invoke requires a function name and arguments"
definitial "list", new Primitive "list", (values, env, kont) ->
(values, env, kont) -> kont.resume(values)
# Only called in rich node mode...
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
metadata_evaluation =
listp: (node) -> node.type == 'list'
symbolp: (node) -> node.type == 'symbol'
numberp: (node) -> node.type == 'number'
stringp: (node) -> node.type == 'string'
commentp: (node) -> node.type == 'comment'
nvalu: (node) -> node.value
mksymbols: (list) -> astSymbolsToLispSymbols(list)
straight_evaluation =
listp: (cell) -> cell.__type == 'list'
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp: (cell) -> typeof cell == 'number'
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp: (cell) -> typeof cell == 'boolean'
nullp: (cell) -> cell == null
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp: (cell) -> nilp(cell)
nvalu: (cell) -> cell
mksymbols: (cell) -> cell
makeEvaluator = (ix = straight_evaluation, ty="straight") ->
(exp, env, kont) ->
if ix.symbolp exp
return evaluateVariable (ix.nvalu exp), env, kont
else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
return kont.resume ix.nvalu exp
else if ix.listp exp
body = ix.nvalu exp
head = car body
if ix.symbolp head
switch (ix.nvalu head)
when "quote" then evaluateQuote (cadr body), env, kont
when "if" then evaluateIf (cdr body), env, kont
when "begin" then evaluateBegin (cdr body), env, kont
when "set!" then evaluateSet (ix.nvalu cadr body), (caddr body), env, kont
when "lambda" then evaluateLambda (ix.mksymbols cadr body), (cddr body), env, kont
when "block" then evaluateBlock (ix.nvalu cadr body), (cddr body), env, kont
when "return-from" then evaluateReturnFrom (ix.nvalu cadr body), (caddr body), env, kont
when "catch" then evaluateCatch (cadr body), (cddr body), env, kont
when "throw" then evaluateThrow (cadr body), (caddr body), env, kont
when "unwind-protect" then evaluateUnwindProtect (cadr body), (cddr body), env, kont
else evaluateApplication (car body), (cdr body), env, kont
else
evaluateApplication (car body), (cdr body), env, kont
else
throw new LispInterpreterError("Can't handle a '#{type}'")
nodeEval = makeEvaluator(metadata_evaluation, "node")
lispEval = makeEvaluator(straight_evaluation, "lisp")
evaluate = (exp, env, kont) ->
(if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, kont)
interpreter = (ast, kont) ->
evaluate ast, env_init, new BottomCont null, kont
module.exports = interpreter

14
chapter3g/test.coffee Normal file
View File

@ -0,0 +1,14 @@
olisp = require '../chapter3/interpreter'
{read, readForms} = require '../chapter1/reader'
{inspect} = require 'util'
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
# console.log lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (throw 1 (throw 2 5)) )) )))"
console.log lisp read "(catch foo (throw foo 33))"
console.log lisp read "(catch 'bar (throw 'bar 3))"
console.log lisp read "(catch 1 (throw 1 7))"

View File

@ -0,0 +1,53 @@
chai = require 'chai'
chai.should()
expect = chai.expect
{cons} = require "cons-lists/lists"
olisp = require '../chapter3g/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: Unwind-Protect", ->
it "protects the value correctly", ->
expect(lisp read "(unwind-protect 1 2").to.equal(1)
it "", ->
expect(lisp read "((lambda (c) (unwind-protect 1 (set! c 2)) c ) 0 ").to.equal(2)
it "", ->
expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0 ").to.equal(5)
it "", ->
expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
it "", ->
expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) ) 0 ").to.equal(5)
it "", ->
expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
describe "Core interpreter #3: Try/Catch with Throw as a function", ->
contain = (fcall) ->
return "(begin ((lambda () (begin (set! funcall (lambda (g . args) (apply g args))) #{fcall}))))"
it "", ->
expect(-> lisp read "(funcall throw 'bar 33").to.throw("bar")
it "", ->
expect(lisp read "(catch 'bar (funcall throw 'bar 11))").to.equal(11)
it "", ->
expect(lisp read "(catch 'bar (* 2 (funcall throw 'bar 5)))").to.equal(5)
it "", ->in
expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (funcall throw 'bar x))) ").to.equal(5)
it "", ->
expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (funcall throw 'bar x)))) ").to.equal(10)
it "", ->
expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (funcall throw 1 (funcall throw 2 5)) )) ))) ").to.equal(105)
it "", ->
expect(lisp read "(catch 2 (* 7 (funcall throw 1 (funcall throw 2 3))))").to.equal(3)