[feat] Lambda-only interpreter. NOT WORKING.
This commit is contained in:
Ken Elf Mathieu Sternberg
parent
1e38327b2a
commit
ea522f6cf6
|
|
@ -10,6 +10,7 @@ bin/_mocha
|
|||
bin/mocha
|
||||
bin/coffee
|
||||
bin/cake
|
||||
bin/coffeelint
|
||||
test-reports.xml
|
||||
LisperatorLanguage
|
||||
chapter?/test.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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue