[feat] Lambda-only interpreter. NOT WORKING.

This commit is contained in:
Ken Elf Mathieu Sternberg 2015-08-15 18:53:24 -07:00
parent 1e38327b2a
commit ea522f6cf6
4 changed files with 367 additions and 336 deletions

1
.gitignore vendored
View File

@ -10,6 +10,7 @@ bin/_mocha
bin/mocha bin/mocha
bin/coffee bin/coffee
bin/cake bin/cake
bin/coffeelint
test-reports.xml test-reports.xml
LisperatorLanguage LisperatorLanguage
chapter?/test.coffee chapter?/test.coffee

View File

@ -2,7 +2,7 @@
cadr, caadr, cadar, caddr, nilp, nil, setcdr, cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists" metacadr, setcar} = require "cons-lists/lists"
{normalizeForms, normalizeForm} = require "../chapter1/astToList" {normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Symbol} = require '../chapter1/reader_types' {Node, Comment, Symbol} = require '../chapter1/reader_types'
class LispInterpreterError extends Error class LispInterpreterError extends Error
name: 'LispInterpreterError' name: 'LispInterpreterError'
@ -27,79 +27,142 @@ astSymbolsToLispSymbols = (node) ->
cadddr = metacadr('cadddr') cadddr = metacadr('cadddr')
metadata_evaluation = intlistp = (node) -> node.type == 'list'
listp: (node) -> node.type == 'list' intsymbolp = (node) -> node.type == 'symbol'
symbolp: (node) -> node.type == 'symbol' intnumberp = (node) -> node.type == 'number'
numberp: (node) -> node.type == 'number' intstringp = (node) -> node.type == 'string'
stringp: (node) -> node.type == 'string' intcommentp = (node) -> node.type == 'comment'
commentp: (node) -> node.type == 'comment' intnvalu = (node) -> if (node.type == 'symbol') then node.value.name else node.value
nvalu: (node) -> node.value intatomp = (node) -> node.type in ['symbol', 'number', 'string']
mksymbols: (list) -> astSymbolsToLispSymbols(list) intmksymbols = (list) -> astSymbolsToLispSymbols(list)
# The hairness of this makes me doubt the wisdom of using Javascript. # 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'
sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean'
sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function' 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}" env_init = (id) -> throw LispInterpreterError "No binding for #{id}"
# Page 129 # This is basically the core definition of 'mem': it returns a
# We don't have an initial value for mem yet? # function enclosing the address (a monotomically increasing number as
update = (mem, addr, value) -> # memory is allocated) and the value. Update is passed the current
(addra) -> if (addra == addr) then value else mem(addra) # 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) -> updates = (mem, addrs, values) ->
if (pairp addrs) if (pairp addrs)
updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values) updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values)
else else
mem 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) -> evaluateVariable = (name, env, mem, kont) ->
kont mem, (env name), mem kont (mem (env name)), mem
# Page 130
evaluateSet = (name, exp, env, mem, kont) -> evaluateSet = (name, exp, env, mem, kont) ->
evaluate exp, env, mem, (value, newmem) -> evaluate exp, env, mem, (value, mem2) ->
kont value, (update newmem, (env name), value) kont value, (update mem2, (env name), value)
# Page 131
# TODO: I don't know that I trust this.
evaluateApplication = (exp, exprs, env, mem, kont) -> 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) -> evaluateArguments = (exprs, env, mem, kont) ->
if (pairp exprs) if (pairp exprs)
evaluate (car exprs), env, mem, (value, mem2) -> evaluate (car exprs), env, mem, (value, mem2) ->
evaluateArguments (cdr exprs), env, mem2, (value2, mems3) -> evaluateArguments (cdr exprs), env, mem2, (value2, mem3) ->
kont (cons value, value2), mems3 kont (cons value, value2), mem3
else else
kont cons(), mem kont cons(), mem
evaluate exp, env, mem, (fun, mems) -> evaluate exp, env, mem, (fun, mem2) ->
evaluateArguments exprs, env, mems, (value2, mem3) -> evaluateArguments exprs, env, mem2, (value2, mem3) ->
if eq (fun sType), sFunction if eq (fun sType), sFunction
(fun sBehavior) value2, mem3, kont (fun sBehavior) value2, mem3, kont
else else
throw new LispInterpreterError "Not a function #{(car value2)}" 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) -> evaluateLambda = (names, exprs, env, mem, kont) ->
allocate 1, mem, (addrs, mem2) -> allocate 1, mem, (addrs, mem2) ->
kont (createFunction (car addrs), (values, mem, kont) -> kont (createFunction (car addrs), (values, mem, kont) ->
@ -109,29 +172,20 @@ evaluateLambda = (names, exprs, env, mem, kont) ->
else else
throw new LispInterpreterError "Incorrect Arrity"), mem2 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) -> evaluateIf = (expc, expt, expf, env, mem, kont) ->
evaluate expc, env, mem, (env, mems) -> 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 # 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) -> evaluateBegin = (exps, env, mem, kont) ->
@ -141,25 +195,216 @@ evaluateBegin = (exps, env, mem, kont) ->
else else
evaluate (car exps), env, mem, kont evaluate (car exps), env, mem, kont
theEmptyList = (msg) ->
switch msg
when sType then sNull
when sBoolify then (x, y) -> x
prox = createBoolean = (value) ->
"quote": (body, env, mem, kont, ix) -> evaluateQuote (cadr body), env, mem, kont combinator = if value then ((x, y) -> x) else ((x, y) -> y)
"if": (body, env, mem, kont, ix) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont (msg) ->
"begin": (body, env, mem, kont, ix) -> evaluateBegin (cdr body), env, mem, kont switch msg
"set!": (body, env, mem, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, mem, kont when sType then sBoolean
"lambda": (body, env, mem, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, mem, kont when sBoolify then combinator
makeEvaluator = (ix = straight_evaluation) -> createSymbol = (value) ->
(exp, env, mem, kont) -> (msg) ->
if ix.atomp exp switch msg
if ix.symbolp exp when sType then sValue
evaluateVariable exp, env, mem, kont 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 else
evaluateQuote exp, env, mem, kont 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 else
body = ix.nvalu exp q theEmptyList, mem
head = car body consify values, q
if prox[(ix.nvalu head)]?
prox[(ix.nvalue head)](body, env, mem, kont, ix) 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 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

View File

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

40
test/test_chapter4.coffee Normal file
View File

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