diff --git a/.gitignore b/.gitignore index 2dd83a7..3dee85b 100644 --- a/.gitignore +++ b/.gitignore @@ -10,6 +10,7 @@ bin/_mocha bin/mocha bin/coffee bin/cake +bin/coffeelint test-reports.xml LisperatorLanguage chapter?/test.coffee diff --git a/chapter4/interpreter.coffee b/chapter4/interpreter.coffee index f120998..4e9ccbb 100644 --- a/chapter4/interpreter.coffee +++ b/chapter4/interpreter.coffee @@ -2,7 +2,7 @@ cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr, setcar} = require "cons-lists/lists" {normalizeForms, normalizeForm} = require "../chapter1/astToList" -{Node, Symbol} = require '../chapter1/reader_types' +{Node, Comment, Symbol} = require '../chapter1/reader_types' class LispInterpreterError extends Error name: 'LispInterpreterError' @@ -27,79 +27,142 @@ astSymbolsToLispSymbols = (node) -> cadddr = metacadr('cadddr') -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) +intlistp = (node) -> node.type == 'list' +intsymbolp = (node) -> node.type == 'symbol' +intnumberp = (node) -> node.type == 'number' +intstringp = (node) -> node.type == 'string' +intcommentp = (node) -> node.type == 'comment' +intnvalu = (node) -> if (node.type == 'symbol') then node.value.name else node.value +intatomp = (node) -> node.type in ['symbol', 'number', 'string'] +intmksymbols = (list) -> astSymbolsToLispSymbols(list) # The hairness of this makes me doubt the wisdom of using Javascript. -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 - -sType = new Symbol 'type' sBehavior = new Symbol 'behavior' +sBehavior = new Symbol 'behavior' +sBoolean = new Symbol 'boolean' +sBoolify = new Symbol 'boolify' sFunction = new Symbol 'function' +sName = new Symbol 'name' +sNull = new Symbol 'null' +sTag = new Symbol 'tag' +sType = new Symbol 'type' +sValue = new Symbol 'value' +sPair = new Symbol 'pair' +sCar = new Symbol 'car' +sCdr = new Symbol 'cdr' +sSetCar = new Symbol 'setcar' +sSetCdr = new Symbol 'setcdr' + +prox = + "quote": (body, env, mem, kont) -> evaluateQuote (cadr body), env, mem, kont + "if": (body, env, mem, kont) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont + "begin": (body, env, mem, kont) -> evaluateBegin (cdr body), env, mem, kont + "set!": (body, env, mem, kont) -> evaluateSet (intnvalu cadr body), (caddr body), env, mem, kont + "lambda": (body, env, mem, kont) -> evaluateLambda (intmksymbols cadr body), (cddr body), env, mem, kont + "or": (body, env, mem, kont) -> evaluateOr (car body), (cdr body), env, mem, kont + +# ___ _ _ +# | __|_ ____ _| |_ _ __ _| |_ ___ _ _ +# | _|\ V / _` | | || / _` | _/ _ \ '_| +# |___|\_/\__,_|_|\_,_\__,_|\__\___/_| +# + +transcode = (value, mem, qont) -> + forms = [ + [intnullp, -> q theEmptyList, mem], + [((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> q (createBoolean value), mem)] + [intsymbolp, (-> q (createSymbol value), mem)] + [intnumberp, (-> q (createNumber value), mem)] + [intpairp, (-> transcode (car intnvalu value), mem, (addr, mem2) -> + (transcode (cdr intvalu value), mem2, (d, mem3) -> + (allocatePair addr, d, mem3, qont)))] + ] + form = form[1] for form in forms when form[0](value) + if len(form) != 1 + throw new LispInterpreterError "Bad form match for #{value}" + form[0]() + + +evaluate = (exp, env, mem, kont) -> + if intatomp exp + if intsymbolp exp + evaluateVariable exp, env, mem, kont + else + evaluateQuote exp, env, mem, kont + else + body = intnvalu exp + head = car body + if prox[(intnvalu head)]? + prox[(intnvalu head)](body, env, mem, kont, ix) + else + evaluateApplication body, (cadr body), env, mem, kont -# Page 129 env_init = (id) -> throw LispInterpreterError "No binding for #{id}" -# Page 129 -# We don't have an initial value for mem yet? -update = (mem, addr, value) -> - (addra) -> if (addra == addr) then value else mem(addra) +# This is basically the core definition of 'mem': it returns a +# function enclosing the address (a monotomically increasing number as +# memory is allocated) and the value. Update is passed the current +# memory, the address, and the value; it returns a function that says +# "If the requested address is my address, return my value, otherwise +# I'll call the memory handed to me at creation time with the address, +# and it'll go down the line." Update basically adds to a 'stack' +# built entirely out of pointers to the base mem. + +update = (mem, addr, value) -> + (addra) -> if (eq addra, addr) then value else (mem addra) -# Page 130 updates = (mem, addrs, values) -> if (pairp addrs) updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values) else mem -# Page 130 +# Memory location zero contains the position of the stack. + +expandStore = (highLocation, mem) -> + update mem, 0, highLocation + +mem_init = expandStore 0, (a) -> + throw new LispInterpreterError "No such address #{a}" + +newLocation = (mem) -> + (mem 0) + 1 + evaluateVariable = (name, env, mem, kont) -> - kont mem, (env name), mem + kont (mem (env name)), mem -# Page 130 evaluateSet = (name, exp, env, mem, kont) -> - evaluate exp, env, mem, (value, newmem) -> - kont value, (update newmem, (env name), value) + evaluate exp, env, mem, (value, mem2) -> + kont value, (update mem2, (env name), value) -# Page 131 -# TODO: I don't know that I trust this. evaluateApplication = (exp, exprs, env, mem, kont) -> + # In chapter 3, this was a series of jumping continuations chasing + # each other. Here, all of the continuations are kept in one place, + # and the argument list is built by tail-calls to evaluateArguments + # until the list is exhausted, at which point the continuation is + # called. The continuation is built in the second paragraph below. + evaluateArguments = (exprs, env, mem, kont) -> if (pairp exprs) evaluate (car exprs), env, mem, (value, mem2) -> - evaluateArguments (cdr exprs), env, mem2, (value2, mems3) -> - kont (cons value, value2), mems3 + evaluateArguments (cdr exprs), env, mem2, (value2, mem3) -> + kont (cons value, value2), mem3 else kont cons(), mem - evaluate exp, env, mem, (fun, mems) -> - evaluateArguments exprs, env, mems, (value2, mem3) -> + evaluate exp, env, mem, (fun, mem2) -> + evaluateArguments exprs, env, mem2, (value2, mem3) -> if eq (fun sType), sFunction (fun sBehavior) value2, mem3, kont else throw new LispInterpreterError "Not a function #{(car value2)}" +# Creates a memory address for the function, then creates a new memory +# address for each argument, then evaluates the expressions in the +# lambda, returning the value of the last one. + evaluateLambda = (names, exprs, env, mem, kont) -> allocate 1, mem, (addrs, mem2) -> kont (createFunction (car addrs), (values, mem, kont) -> @@ -109,31 +172,22 @@ evaluateLambda = (names, exprs, env, mem, kont) -> else throw new LispInterpreterError "Incorrect Arrity"), mem2 -allocate = (num, mem, q) -> - if (num > 0) - do -> - addr = newLocation s - allocate (num - 1), (expandStore addr, mem), (addrs, mem2) -> - q (cons addr, addrs), mem2 - else - q cons(), mem - -expandStore = (highLocation, mem) -> - update mem, 0, highLocation - -newLocation = (mem) -> - (mem 0) + 1 - - - -# Page 128 evaluateIf = (expc, expt, expf, env, mem, kont) -> evaluate expc, env, mem, (env, mems) -> - evaluate ((env "boolify") expt, expf), env, mems, kont + evaluate ((env sBoolify) expt, expf), env, mems, kont + +evaluateQuote = (c, env, mem, kont) -> + transcode (normalizeForms c), mem, kont + +# By starting over "from here," we undo all side-effect assignments +# that were effected by expression 1 + +evaluateOr = (exp1, exp2, env, mem, kont) -> + evaluate exp1, env, mem, (value, mem2) -> + (value sBoolify) (-> kont value, mem2), (-> evaluate exp2, env, mem, kont) -# Page 129 # I like how, in this version, we explicitly throw away the meaning of -# all but the last statement in evaluateBegin. +# all but the last statement in evaluateBegin. evaluateBegin = (exps, env, mem, kont) -> if pairp (cdr exps) evaluate (car exps), env, mem, (_, mems) -> @@ -141,25 +195,216 @@ evaluateBegin = (exps, env, mem, kont) -> else evaluate (car exps), env, mem, kont +theEmptyList = (msg) -> + switch msg + when sType then sNull + when sBoolify then (x, y) -> x -prox = - "quote": (body, env, mem, kont, ix) -> evaluateQuote (cadr body), env, mem, kont - "if": (body, env, mem, kont, ix) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont - "begin": (body, env, mem, kont, ix) -> evaluateBegin (cdr body), env, mem, kont - "set!": (body, env, mem, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, mem, kont - "lambda": (body, env, mem, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, mem, kont +createBoolean = (value) -> + combinator = if value then ((x, y) -> x) else ((x, y) -> y) + (msg) -> + switch msg + when sType then sBoolean + when sBoolify then combinator -makeEvaluator = (ix = straight_evaluation) -> - (exp, env, mem, kont) -> - if ix.atomp exp - if ix.symbolp exp - evaluateVariable exp, env, mem, kont - else - evaluateQuote exp, env, mem, kont +createSymbol = (value) -> + (msg) -> + switch msg + when sType then sValue + when sName then value + when sBoolify then (x, y) -> x + +createNumber = (value) -> + (msg) -> + switch msg + when sType then sNumber + when sValue then value + when sBoolify then (x, y) -> x + +createFunction = (tag, behavior) -> + (msg) -> + switch msg + when sType then sNumber + when sBoolify then (x, y) -> x + when sTag then tag + when sBehavior then behavior + +# I'm not sure I get the difference between allocate and update. +# Update appears to have the power to append to the memory list +# without updating highLocation. If I'm reading this correct, then +# what we're actually looking at is a simulation of a memory +# subsystem, with expandStore/newLocation/allocate taking on the duty +# of "managing" our stack, and update actually just doing the managing +# the stack, and letting the garbage collector do its thing when a +# pointer to memory function goes out of scope. In short: the +# allocate collection of functions is "going through the motions" of +# managing memory; had this been a real memory manager, you'd have +# a lot more work to do. + +allocate = (num, mem, q) -> + if (num > 0) + do -> + addr = newLocation mem + allocate (num - 1), (expandStore addr, mem), (addrs, mem2) -> + q (cons addr, addrs), mem2 + else + q cons(), mem + +allocateList = (values, mem, q) -> + consify = (values, q) -> + if (pairp values) + consify (cdr values), (value, mem2) -> + allocatePair (car values), value, mem2, q else - body = ix.nvalu exp - head = car body - if prox[(ix.nvalu head)]? - prox[(ix.nvalue head)](body, env, mem, kont, ix) + q theEmptyList, mem + consify values, q + +allocatePair = (addr, d, mem, q) -> + allocate 2, mem, (addrs, mem2) -> + q (createPair (car addrs), (cadr addrs)), (update (update mem2, (car addrs), addr), (cadr addrs), d) + +createPair = (a, d) -> + (msg) -> + switch msg + when sType then sPair + when sBoolify then (x, y) -> x + when sSetCar then (mem, val) -> update mem, a, val + when sSetCdr then (mem, val) -> update mem, d, val + when sCar then a + when sCdr then d + +env_global = env_init +mem_global = mem_init + +# The name is pushed onto the global environment, with a corresponding +# address. The address is pushed onto the current memory, with the +# corresponding boxed value. + +defInitial = (name, value) -> + allocate 1, mem_global, (addrs, mem2) -> + env_global = update env_global, (new Symbol name), (car addrs) + mem_global = update mem2, (car addrs), value + +defPrimitive = (name, arity, value) -> + defInitial name, allocate 1, mem_global, (addrs, mem2) -> + mem_global = expandStore (car addrs), mem2 + createFunction (car addrs), (values, mem, kont) -> + if (eq arity (length values)) + value values, mem, kont else - evaluateApplication body, (cadr body), env, mem, kont + throw new LispInterpreterError "Wrong arity for #{name}" + +# ___ _ _ _ _ _ _ _ +# |_ _|_ _ (_) |_(_) (_)_____ _| |_(_)___ _ _ +# | || ' \| | _| | | |_ / _` | _| / _ \ ' \ +# |___|_||_|_|\__|_|_|_/__\__,_|\__|_\___/_||_| +# + + +defInitial "true", createBoolean true +defInitial "false", createBoolean false +defInitial "nil", null + +defPrimitive "<=", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createBoolean (((car values) sValue) <= ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Comparison requires numbers" + +defPrimitive "<", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createBoolean (((car values) sValue) < ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Comparison requires numbers" + +defPrimitive ">=", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createBoolean (((car values) sValue) >= ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Comparison requires numbers" + +defPrimitive ">", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createBoolean (((car values) sValue) > ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Comparison requires numbers" + +defPrimitive "=", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createBoolean (((car values) sValue) == ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Comparison requires numbers" + +defPrimitive "*", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createNumber (((car values) sValue) * ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Multiplication requires numbers" + +defPrimitive "+", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createNumber (((car values) sValue) + ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Addition requires numbers" + +defPrimitive "/", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createNumber (((car values) sValue) / ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Division requires numbers" + +defPrimitive "*", 2, (values, mem, kont) -> + if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber) + kont (createNumber (((car values) sValue) - ((cadr values) sValue))), mem + else + throw new LispInterpreterError "Subtraction requires numbers" + +defPrimitive "cons", 2, (values, mem, kont) -> + allocatePair (car values), (cadr values), mem, kont + +defPrimitive "car", 1, (values, mem, kont) -> + if (eq ((car values) sType) sPair) + kont (mem ((car values) sCar)), mem + else + throw new LispInterpreterError "Not a pair" + +defPrimitive "cdr", 1, (values, mem, kont) -> + if (eq ((car values) sType) sPair) + kont (mem ((car values) sCdr)), mem + else + throw new LispInterpreterError "Not a pair" + +defPrimitive "setcdr", 2, (values, mem, kont) -> + if (eq ((car values) sType) sPair) + pair = (car values) + kont pair, ((pair sSetCdr) mem, (cadr values)) + else + throw new LispInterpreterError "Not a pair" + +defPrimitive "setcar", 2, (values, mem, kont) -> + if (eq ((car values) sType) sPair) + pair = (car values) + kont pair, ((pair sSetCar) mem, (cadr values)) + else + throw new LispInterpreterError "Not a pair" + +defPrimitive "eqv?", (values, mem, kont) -> + kont createBoolean ( + if (eq ((car values) sType) ((cadr values) sType)) + switch ((car values) sType) + when sBoolean + ((car values) sBoolify) (((cadr values) sBoolify) true, false), (((cadr values) sBoolify) false, true) + when sSymbol + eq ((car values) sName), ((cadr values) sName) + when sNumber + ((car values) sName) == ((cadr values) sName) + when sPair + (((car values) sCar) == ((cadr values) sCar) and + ((car values) sCdr) == ((cadr values) sCdr)) + when sFunction + ((car value) sTag) == ((cadr value) sTag) + else false + else false) + +module.exports = (ast, kont) -> + evaluate ast, env_global, mem_global, kont diff --git a/chapter4/interpreter.js b/chapter4/interpreter.js deleted file mode 100644 index c49339e..0000000 --- a/chapter4/interpreter.js +++ /dev/null @@ -1,255 +0,0 @@ -// Generated by CoffeeScript 1.9.1 -(function() { - var LispInterpreterError, Node, Symbol, astSymbolsToLispSymbols, caadr, caar, cadar, cadddr, caddr, cadr, car, cdar, cddr, cdr, cons, env_init, eq, evaluateApplication, evaluateBegin, evaluateIf, evaluateLambda, evaluateSet, evaluateVariable, listToString, listToVector, makeEvaluator, metacadr, metadata_evaluation, nil, nilp, normalizeForm, normalizeForms, pairp, prox, ref, ref1, ref2, sBehavior, sFunction, sType, setcar, setcdr, straight_evaluation, the_false_value, update, updates, - extend = function(child, parent) { for (var key in parent) { if (hasProp.call(parent, key)) child[key] = parent[key]; } function ctor() { this.constructor = child; } ctor.prototype = parent.prototype; child.prototype = new ctor(); child.__super__ = parent.prototype; return child; }, - hasProp = {}.hasOwnProperty; - - ref = require("cons-lists/lists"), listToString = ref.listToString, listToVector = ref.listToVector, pairp = ref.pairp, cons = ref.cons, car = ref.car, cdr = ref.cdr, caar = ref.caar, cddr = ref.cddr, cdar = ref.cdar, cadr = ref.cadr, caadr = ref.caadr, cadar = ref.cadar, caddr = ref.caddr, nilp = ref.nilp, nil = ref.nil, setcdr = ref.setcdr, metacadr = ref.metacadr, setcar = ref.setcar; - - ref1 = require("../chapter1/astToList"), normalizeForms = ref1.normalizeForms, normalizeForm = ref1.normalizeForm; - - ref2 = require('../chapter1/reader_types'), Node = ref2.Node, Symbol = ref2.Symbol; - - LispInterpreterError = (function(superClass) { - extend(LispInterpreterError, superClass); - - LispInterpreterError.prototype.name = 'LispInterpreterError'; - - function LispInterpreterError(message) { - this.message = message; - } - - return LispInterpreterError; - - })(Error); - - the_false_value = cons("false", "boolean"); - - eq = function(id1, id2) { - if (id1 instanceof Symbol && id2 instanceof Symbol) { - return id1.name === id2.name; - } - return id1 === id2; - }; - - astSymbolsToLispSymbols = function(node) { - var handler; - if (nilp(node)) { - return nil; - } - if (!node.type === 'list') { - throw new LispInterpreterError("Not a list of variable names"); - } - handler = function(cell) { - if (nilp(cell)) { - return nil; - } - return cons((car(cell)).value, handler(cdr(cell))); - }; - return handler(node.value); - }; - - cadddr = metacadr('cadddr'); - - metadata_evaluation = { - listp: function(node) { - return node.type === 'list'; - }, - symbolp: function(node) { - return node.type === 'symbol'; - }, - numberp: function(node) { - return node.type === 'number'; - }, - stringp: function(node) { - return node.type === 'string'; - }, - commentp: function(node) { - return node.type === 'comment'; - }, - nvalu: function(node) { - return node.value; - }, - mksymbols: function(list) { - return astSymbolsToLispSymbols(list); - } - }; - - straight_evaluation = { - listp: function(cell) { - return cell.__type === 'list'; - }, - symbolp: function(cell) { - var ref3; - return typeof cell === 'string' && cell.length > 0 && ((ref3 = cell[0]) !== "\"" && ref3 !== ";"); - }, - commentp: function(cell) { - return typeof cell === 'string' && cell.length > 0 && cell[0] === ";"; - }, - numberp: function(cell) { - return typeof cell === 'number'; - }, - stringp: function(cell) { - return typeof cell === 'string' && cell.length > 0 && cell[0] === "\""; - }, - boolp: function(cell) { - return typeof cell === 'boolean'; - }, - nullp: function(cell) { - return cell === null; - }, - vectorp: function(cell) { - return (!straight_evaluation.listp(cell)) && toString.call(cell) === '[object Array]'; - }, - recordp: function(cell) { - return (cell._prototype == null) && toSTring.call(cell) === '[object Object]'; - }, - objectp: function(cell) { - return (cell._prototype != null) && toString.call(cell) === '[object Object]'; - }, - nilp: function(cell) { - return nilp(cell); - }, - nvalu: function(cell) { - return cell; - }, - mksymbols: function(cell) { - return cell; - } - }; - - sType = new Symbol('type'); - - sBehavior = new Symbol('behavior'); - - sFunction = new Symbol('function'); - - env_init = function(id) { - throw LispInterpreterError("No binding for " + id); - }; - - update = function(mem, addr, value) { - return function(addra) { - if (addra === addr) { - return value; - } else { - return mem(addra); - } - }; - }; - - updates = function(mem, addrs, values) { - if (pairp(addrs)) { - return updates(update(mem, car(addrs), car(values)), cdr(addrs), cdr(values)); - } else { - return mem; - } - }; - - evaluateVariable = function(name, env, mem, kont) { - return kont(mem, env(name), mem); - }; - - evaluateSet = function(name, exp, env, mem, kont) { - return evaluate(exp, env, mem, function(value, newmem) { - return kont(value, update(newmem, env(name), value)); - }); - }; - - evaluateApplication = function(exp, exprs, env, mem, kont) { - var evaluateArguments; - evaluateArguments = function(exprs, env, mem, kont) { - if (pairp(exprs)) { - return evaluate(car(exprs), env, mem, function(value, mem2) { - return evaluateArguments(cdr(exprs), env, mem2, function(value2, mems3) { - return kont(cons(value, value2), mems3); - }); - }); - } else { - return kont(cons(), mem); - } - }; - return evaluate(exp, env, mem, function(fun, mems) { - return evaluateArguments(exprs, env, mems, function(value2, mem3) { - if (eq(fun(sType), sFunction)) { - return (fun(sBehavior))(value2, mem3, kont); - } else { - throw new LispInterpreterError("Not a function " + (car(value2))); - } - }); - }); - }; - - evaluateLambda = function(names, exprs, env, mem, kont) { - return allocate(1, mem, function(addrs, mem2) { - return kont(createFunction(car(addrs), function(values, mem, kont) { - if (eq(length(names), length(values))) { - return allocate(length(names), mem, function(addrs, mem2) { - return evaluateBegin(exprs, updates(env, names, addrs), updates(mem2, addrs, values), kont); - }); - } else { - throw new LispInterpreterError("Incorrect Arrity"); - } - }), mem2); - }); - }; - - evaluateIf = function(expc, expt, expf, env, mem, kont) { - return evaluate(expc, env, mem, function(env, mems) { - return evaluate((env("boolify"))(expt, expf), env, mems, kont); - }); - }; - - evaluateBegin = function(exps, env, mem, kont) { - if (pairp(cdr(exps))) { - return evaluate(car(exps), env, mem, function(_, mems) { - return evaluateBegin(cdr(exps), env, mems, kont); - }); - } else { - return evaluate(car(exps), env, mem, kont); - } - }; - - prox = { - "quote": function(body, env, mem, kont, ix) { - return evaluateQuote(cadr(body), env, mem, kont); - }, - "if": function(body, env, mem, kont, ix) { - return evaluateIf(cadr(body), caddr(body), cadddr(body), env, mem, kont); - }, - "begin": function(body, env, mem, kont, ix) { - return evaluateBegin(cdr(body), env, mem, kont); - }, - "set!": function(body, env, mem, kont, ix) { - return evaluateSet(ix.nvalu(cadr(body)), caddr(body), env, mem, kont); - }, - "lambda": function(body, env, mem, kont, ix) { - return evaluateLambda(ix.mksymbols(cadr(body)), cddr(body), env, mem, kont); - } - }; - - makeEvaluator = function(ix) { - if (ix == null) { - ix = straight_evaluation; - } - return function(exp, env, mem, kont) { - var body, head; - if (ix.atomp(exp)) { - if (ix.symbolp(exp)) { - return evaluateVariable(exp, env, mem, kont); - } else { - return evaluateQuote(exp, env, mem, kont); - } - } else { - body = ix.nvalu(exp); - head = car(body); - if (prox[ix.nvalu(head)] != null) { - return prox[ix.nvalue(head)](body, env, mem, kont, ix); - } else { - return evaluateApplication(body, cadr(body), env, mem, kont); - } - } - }; - }; - -}).call(this); diff --git a/test/test_chapter4.coffee b/test/test_chapter4.coffee new file mode 100644 index 0000000..eacab40 --- /dev/null +++ b/test/test_chapter4.coffee @@ -0,0 +1,40 @@ +chai = require 'chai' +chai.should() +expect = chai.expect + +{cons} = require "cons-lists/lists" +olisp = require '../chapter4/interpreter' +{read, readForms} = require '../chapter4/reader' + +the_false_value = (cons "false", "boolean") + +lisp = (ast) -> + ret = undefined + olisp ast, (i) -> ret = i + return ret + +describe "Core interpreter #4: Pure Lambda Memory", -> + it "Understands equality", -> + expect(lisp read "(eq? 'a 'b)").to.equal(false) + expect(lisp read "(eq? 'a 'a)").to.equal(true) + expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false) + expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true) + expect(lisp read "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true) + expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false) + + it "Understands equivalence", -> + expect(lisp read "(eqv? '1 '2)").to.equal(false) + expect(lisp read "(eqv? 1 1)").to.equal(true) + expect(lisp read "(eqv? 'a 'b)").to.equal(false) + expect(lisp read "(eqv? 'a 'a)").to.equal(true) + expect(lisp read "(eqv? (cons 1 2) (cons 1 2))").to.equal(false) + expect(lisp read "((lambda (a) (eqv? a a)) (cons 1 2))").to.equal(true) + expect(lisp read "((lambda (a) (eqv? a a)) (lambda (x) x))").to.equal(true) + expect(lisp read "(eqv? (lambda (x) 1) (lambda (x y) 2))").to.equal(false) + + it "Does special OR (backtracking without side-effect)", -> + expr1 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) \"OK\" \"KO\"))) 1)" + expect(lisp read expr1).to.equal("OK") + expr2 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) (begin (set! x 3) x) \"KO\"))) 1)" + expect(lisp read expr2).to.equal(3) +