diff --git a/chapter3g/interpreter.coffee b/chapter3g/interpreter.coffee new file mode 100644 index 0000000..d20c6b2 --- /dev/null +++ b/chapter3g/interpreter.coffee @@ -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 diff --git a/chapter3g/test.coffee b/chapter3g/test.coffee new file mode 100644 index 0000000..8cdfb05 --- /dev/null +++ b/chapter3g/test.coffee @@ -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))" diff --git a/test/test_chapter3g.coffee b/test/test_chapter3g.coffee new file mode 100644 index 0000000..e147fc7 --- /dev/null +++ b/test/test_chapter3g.coffee @@ -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) + + + + +