Hey, it runs the test. It doesn't return the right value, but...

This commit is contained in:
Elf M. Sternberg 2015-08-25 22:01:21 -07:00
parent db2e93b2f3
commit e0b6b44178
7 changed files with 363 additions and 471 deletions

View File

@ -1,6 +1,7 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, {listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
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"
{map} = require "cons-lists/reduce"
{length} = require "cons-lists/reduce" {length} = require "cons-lists/reduce"
{normalizeForms, normalizeForm} = require "../chapter1/astToList" {normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Comment, Symbol} = require '../chapter1/reader_types' {Node, Comment, Symbol} = require '../chapter1/reader_types'
@ -31,18 +32,34 @@ astSymbolsToLispSymbols = (node) ->
cadddr = metacadr('cadddr') cadddr = metacadr('cadddr')
intlistp = (node) -> node.type == 'list' consp = (e) ->
intpairp = (node) -> node.type == 'list' and ((node.value.length < 2) or node.value[1].node.type != 'list') ((pairp e) and (typeof (car e) == 'number') and
intsymbolp = (node) -> node.type == 'symbol' or node instanceof Symbol ((car e) > 0) and (pairp cdr e) and (typeof (cadr e) == 'number') and
intnumberp = (node) -> node.type == 'number' ((cadr e) > 0) and (nilp cddr e))
intstringp = (node) -> node.type == 'string'
intcommentp = (node) -> node.type == 'comment'
intnvalu = (node) -> node.value
intatomp = (node) -> node.type in ['symbol', 'number', 'string']
intnullp = (node) -> node.type == 'symbol' and node.value.name == 'null'
intmksymbols = (list) -> astSymbolsToLispSymbols(list)
# The hairness of this makes me doubt the wisdom of using Javascript. convert = (exp, store) ->
conv = (e) ->
if consp e
cons (conv content.v, (store (car e))), (conv content.v, (store (cadr e)))
else
e
conv (content.v e)
translate = (exp, store, qont) ->
if (pairp exp)
translate (car exp), store, (val1, store1) ->
translate (cdr exp), store1, (val2, store2) ->
allocate = (->
loc = 0
(store, num, qont) ->
addrs = cons()
n = num
until n <= 0
loc = loc + 1
n = n - 1
cons loc, addrs
qont store, addrs)()
sBehavior = new Symbol 'behavior' sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean' sBoolean = new Symbol 'boolean'
@ -63,417 +80,257 @@ sCdr = new Symbol 'cdr'
sSetCar = new Symbol 'setcar' sSetCar = new Symbol 'setcar'
sSetCdr = new Symbol 'setcdr' sSetCdr = new Symbol 'setcdr'
prox = class Value
"quote": (body, env, mem, kont) -> evaluateQuote (cadr body), env, mem, kont constructor: (@content) ->
"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 (cadr body), (caddr body), env, mem, kont
# ___ _ _ inValue = (f) ->
# | __|_ ____ _| |_ _ __ _| |_ ___ _ _ new Value(f)
# | _|\ V / _` | | || / _` | _/ _ \ '_|
# |___|\_/\__,_|_|\_,_\__,_|\__\___/_|
#
transcode = (value, mem, qont) -> ValueToFunction = (e) ->
forms = [ c = e.content
[intnullp, -> qont theEmptyList, mem], if (typeof c == 'function') then c else throw new LispInterpreterError("Not a function: " + Object.toString(c))
[((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
[intsymbolp, (-> qont (createSymbol value), mem)]
[intnumberp, (-> qont (createNumber value), mem)]
[intstringp, (-> qont (createString value), mem)]
[intlistp, (-> transcode (car intnvalu value), mem, (addr, mem2) ->
(transcode (cdr intvalu value), mem2, (d, mem3) ->
(allocatePair addr, d, mem3, qont)))]
]
found = (form[1] for form in forms when form[0](value))
if found.length != 1
throw new LispInterpreterError "Bad transcode match for #{value}"
found[0]()
transcode2 = (value, mem, qont) -> ValueToPair = (e) ->
forms = [ c = e.content
[((v) -> v instanceof Symbol and v.name == 'null'), (-> qont theEmptyList, mem)], if pairp c then c else throw new LispInterpreterError("Not a pair: " + Object.toString(c))
[((v) -> v instanceof Symbol and v.name in ['#t', '#f']), (-> qont (createBoolean value), mem)]
[((v) -> v instanceof Symbol), (-> qont (createSymbol value), mem)]
[((v) -> typeof v == 'string'), (-> qont (createString value), mem)]
[((v) -> typeof v == 'number'), (-> qont (createNumber value), mem)]
[((v) -> v.__type == 'list'), (-> transcode (car value), mem, (addr, mem2) ->
(transcode (cdr value), mem2, (d, mem3) ->
(allocatePair addr, d, mem3, qont)))]
]
found = (form[1] for form in forms when form[0](value))
if found.length < 1
throw new LispInterpreterError "Bad transcode match for #{value}"
found[0]()
ValueToNumber = (e) ->
c = e.content
if (typeof c == 'number') then c else throw new LispInterpreterError("Not a number: " + Object.toString(c))
transcodeBack = (value, mem) ->
forms = [
[sBoolean, ((v) -> ((v sBoolify) true, false))]
[sSymbol, ((v) -> (v sName))]
[sString, ((v) -> (v sValue))]
[sNumber, ((v) -> (v sValue))]
[sPair, ((v) ->
cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
[sFunction, (v) -> v]
]
found = (form[1] for form in forms when (eq (value sType), form[0]))
if found.length != 1
throw new LispInterpreterError "Bad transcode-back match for #{value}"
found[0](value)
evaluate = (exp, env, mem, kont) ->
if intatomp exp
if intsymbolp exp
evaluateVariable (intnvalu exp), env, mem, kont
else
evaluateQuote exp, env, mem, kont
else
body = intnvalu exp
head = car body
pname = (intnvalu head)
if pname instanceof Symbol and prox[pname.name]?
prox[pname.name](body, env, mem, kont)
else
evaluateApplication head, (cdr body), env, mem, kont
env_init = (id) ->
throw new LispInterpreterError "No binding for " + id
# 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)
updates = (mem, addrs, values) ->
if (pairp addrs)
updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values)
else
mem
# 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
evaluateSet = (name, exp, env, mem, kont) ->
evaluate exp, env, mem, (value, mem2) ->
kont value, (update mem2, (env name), value)
evaluateApplication = (exp, exprs, env, mem, kont) ->
# In chapter 3, this was a series of jumping continuations chasing class Interpreter
# each other. Here, all of the continuations are kept in one place, constructor: ->
# and the argument list is built by tail-calls to evaluateArguments arity_check = (name, arity, fn) =>
# until the list is exhausted, at which point the continuation is (values, kont, store) =>
# called. The continuation is built in the second paragraph below. if not eq (length values), arity
throw new LispInterpreterError "Incorrect Arity for #{name}"
fn.call(@, values, kont, store)
evaluateArguments = (exprs, env, mem, kont) -> @definitial "cons", inValue arity_check "cons", 2, (values, kont, store) =>
if (pairp exprs) allocate store, 2, (store, addrs) =>
evaluate (car exprs), env, mem, (value, mem2) -> kont (inValue (cons (car addr), (cadr addr))), (@extends store, addrs, values)
evaluateArguments (cdr exprs), env, mem2, (value2, mem3) ->
kont (cons value, value2), mem3 @definitial "car", inValue arity_check "car", 1, (values, kont, store) =>
kont (store car @valueToPair (car values)), store
@definitial "cdr", inValue arity_check "car", 1, (values, kont, store) =>
kont (store cadr @valueToPair (car values)), store
@defprimitive "pair?", ((v) -> inValue (consp v.content)), 1
@defprimitive "eq?", ((v1, v2) -> inValue (eq v1.content, v2.content)), 2
@defprimitive "symbol?", ((v) -> inValue (symbolp v.content)), 1
@definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) =>
kont (car values), (@extend store, (car (ValueToPair (car values))), (cadr values))
@definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) =>
kont (car values), (@extend store, (cadr (ValueToPair (car values))), (cadr values))
@defarithmetic "+", ((x, y) -> x + y), 2
@defarithmetic "-", ((x, y) -> x - y), 2
@defarithmetic "*", ((x, y) -> x * y), 2
@defarithmetic "/", ((x, y) -> x / y), 2
@defarithmetic "<", ((x, y) -> x < y), 2
@defarithmetic ">", ((x, y) -> x > y), 2
@defarithmetic "=", ((x, y) -> x == y), 2
@defarithmetic "<=", ((x, y) -> x <= y), 2
@defarithmetic ">=", ((x, y) -> x >= y), 2
@defarithmetic "%", ((x, y) -> x % y), 2
@definitial "apply", arity_check "apply", 2, inValue (values, kont, store) ->
flat = (v) ->
if pairp v.content
cons (store (car (ValueToPair v))), (flat (store (cadr (ValueToPair v))))
else
cons()
collect = (values) ->
if nullp cdr values
flat car values
else
cons (car values), (collect cdr values)
(ValueToFunction (car values)) (collect (cdr values)), kont, store
@definitial '#t', (inValue true)
@definitial '#f', (inValue false)
@definitial 'nil', (inValue cons())
@definitial "x", null
@definitial "y", null
@definitial "z", null
@definitial "a", null
@definitial "b", null
@definitial "c", null
@definitial "foo", null
@definitial "bar", null
@definitial "hux", null
@definitial "fib", null
@definitial "fact", null
@definitial "visit", null
@definitial "length", null
@definitial "primes", null
@loc = 0
loc: 0 # For allocate
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
meaning: (e) ->
meaningTable = [
[sQuote, ((e) => @meaningQuotation (cadr e))]
[sLambda, ((e) => @meaningAbstraction (cadr e), (cddr e))]
[sIf, ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))]
[sBegin, ((e) => @meaningSequence (cdr e))]
[sSet, ((e) => @meaningAssignment (cadr e), (caddr e))]
]
if @atomp e
if @symbolp e then (@meaningReference e) else (@meaningQuotation e)
else else
kont cons(), mem found = (form[1] for form in forms when form[0](e))
if found.length == 1 then found[0](e) else @meaningApplication (car e), (cdr e)
evaluate exp, env, mem, (fun, mem2) -> meaningQuotation: (val) ->
evaluateArguments exprs, env, mem2, (value2, mem3) -> (env, kont, store) ->
if eq (fun sType), sFunction (translate val, store, kont)
(fun sBehavior) value2, mem3, kont
meaningReference: (name) ->
(env, kont, store) ->
kont (store (env name)), store
# Extensional alternative
meaningAlternative: (exp1, exp2, exp3) ->
boolify = (value) ->
if (eq? value (inValue false)) then ((x, y) -> y) else ((x, y) -> x)
ef = (val, val1, val2) ->
val val1, val2
(env, kont, store) =>
hkont = (val, store1) =>
ef (boolify val), ((@meaning exp2) env, kont, store1), ((@meaning exp3) env, kont, store1)
(@meaning exp1)(env, hkont, store)
# Assignment
meaningAssignment: (name, exp) ->
(env, kont, store) =>
hkont = (val, store1) ->
kont value, (extend store1, (env name), val)
(@meaning exp)(env, hkont, store)
# Abstraction (keeps a lambda)
meaningAbstraction: (names, exps) ->
(env, kont, store) =>
funcrep = (vals, kont1, store1) =>
if not (eq (length vals), (length names))
throw new LispInterpreterError("Incorrect Arity.")
functostore = (store2, addrs) =>
(@meaningsSequence exps) (@extends env, names, addrs), kont1, (@extends store2, addrs, vals)
allocate store1, (length names), functostore
kont inValue, funcrep
meaningVariable: (name) ->
(m) =>
(vals, env, kont, store) =>
allocate store, 1, (store, addrs) =>
addr = (car addrs)
m (cdr vals), (@extend env, names, addr), kont, (@extend store, addr, (car vals))
meaningApplication: (exp, exps) ->
(env, kont, store) =>
hkont = (func, store1) =>
kont2 = (values, store2) ->
(ValueToFunction func) values, kont, store2
(@meaning exps) env, kont2, store1
(@meaning exp) env, hkont, store
meaningSequence: (exps) ->
meaningsMultipleSequence = (exp, exps) =>
(env, kont, store) =>
hkont = (values, store1) ->
(meaningsSequence exps) env, kont, store1
(@meaning exp) env, hkont, store
meaningsSingleSequence = (exp) =>
(env, kont, store) =>
(@meaning exp) env, kont, store
(env, kont, store) ->
if not (pairp exps)
throw new LispInterpreterError("Illegal Syntax")
if pairp cdr exps
meaningsMultipleSequence (car exps), (cdr exps)
else else
throw new LispInterpreterError "Not a function #{(car value2)}" meaningSingleSequence (car exps)
# Creates a memory address for the function, then creates a new memory meanings: (exps) =>
# address for each argument, then evaluates the expressions in the meaningSomeArguments = (exp, exps) =>
# lambda, returning the value of the last one. (env, kont, store) =>
hkont = (value, store1) ->
hkont2 = (values, store2) ->
kont (cons value, values), store2
(@meanings exps) env, khont2, store1
(@meaning exp) env, hkont, store
evaluateLambda = (names, exprs, env, mem, kont) -> meaningNoArguments = (env, kont, store) -> (k (cons()), store)
allocate 1, mem, (addrs, mem2) ->
kont (createFunction (car addrs), (values, mem, kont) ->
if eq (length names), (length values)
allocate (length names), mem, (addrs, mem2) ->
evaluateBegin exprs, (updates env, names, addrs), (updates mem2, addrs, values), kont
else
throw new LispInterpreterError "Incorrect Arrity"), mem2
evaluateIf = (expc, expt, expf, env, mem, kont) -> if pairp exps
evaluate expc, env, mem, (env, mems) -> meaningSomeArguments (car exps), (cdr exps)
evaluate ((env sBoolify) expt, expf), env, mems, kont
evaluateQuote = (c, env, mem, kont) ->
transcode2 (normalizeForm 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))()
# I like how, in this version, we explicitly throw away the meaning of
# all but the last statement in evaluateBegin.
evaluateBegin = (exps, env, mem, kont) ->
if pairp (cdr exps)
evaluate (car exps), env, mem, (_, mems) ->
evaluateBegin (cdr exps), env, mems, kont
else
evaluate (car exps), env, mem, kont
theEmptyList = (msg) ->
switch msg
when sType then sNull
when sBoolify then (x, y) -> x
createBoolean = (value) ->
combinator = if value then ((x, y) -> x) else ((x, y) -> y)
(msg) ->
switch msg
when sType then sBoolean
when sBoolify then combinator
createSymbol = (value) ->
(msg) ->
switch msg
when sType then sSymbol
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
createString = (value) ->
(msg) ->
switch msg
when sType then sString
when sValue then value
when sBoolify then (x, y) -> x
createFunction = (tag, behavior) ->
(msg) ->
switch msg
when sType then sFunction
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 else
q theEmptyList, mem meaningNoArgument()
consify values, q
allocatePair = (addr, d, mem, q) -> extend: (fn, pt, im) ->
allocate 2, mem, (addrs, mem2) -> (x) -> if (eq pt, x) then im else (fn x)
q (createPair (car addrs), (cadr addrs)), (update (update mem2, (car addrs), addr), (cadr addrs), d)
createPair = (a, d) -> extends: (fn, pts, ims) ->
(msg) -> if (pairp pts)
switch msg @extend (@extends fn, (cdr pts), (cdr ims)), (car pts), (car ims)
when sType then sPair else
when sBoolify then (x, y) -> x fn
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 store_init: (a) -> throw new LispInterpreterError "No such address"
mem_global = mem_init env_init: (a) -> throw new LispInterpreterError "No such variable"
# The name is pushed onto the global environment, with a corresponding definitial: (name, value) ->
# address. The address is pushed onto the current memory, with the allocate @store_init, 1, (store, addrs) =>
# corresponding boxed value. @env_init = @extend @env_init, name, (car addrs)
@store_init = @extend store, (car addrs), value
defInitial = (name, value) -> defprimitive: (name, value, arity) ->
if typeof name == 'string' callable = (values, kont, store) =>
name = new Symbol name if not eq(arity, (length values))
allocate 1, mem_global, (addrs, mem2) -> throw new LispInterpreterError "Incorrect Arity for #{name}"
env_global = update env_global, name, (car addrs) kont (inValue (value.apply(@, [ValueToNumber(v) for v in values]))), store
mem_global = update mem2, (car addrs), value @definitial name, (inValue callable)
defPrimitive = (name, arity, value) -> defarithmetic: (name, value, arity) ->
defInitial name, allocate 1, mem_global, (addrs, mem2) -> callable = (values, kont, store) ->
mem_global = expandStore (car addrs), mem2 if not eq arity, (length values)
createFunction (car addrs), (values, mem, kont) -> throw new LispInterpreterError "Incorrect Arity for #{name}"
if (eq arity, (length values)) kont (inValue (apply value, (map ValueToIngeter, values))), store
value values, mem, kont (@defprimitive name, value, arity) (name), inValue callable
else
throw new LispInterpreterError "Wrong arity for #{name}"
# ___ _ _ _ _ _ _ _
# |_ _|_ _ (_) |_(_) (_)_____ _| |_(_)___ _ _
# | || ' \| | _| | | |_ / _` | _| / _ \ ' \
# |___|_||_|_|\__|_|_|_/__\__,_|\__|_\___/_||_|
#
defInitial "#t", createBoolean true
defInitial "#f", 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) sType), 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) sType), 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 "eq?", 2, (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 sPair
(((car values) sCar) == ((cadr values) sCar) and
((car values) sCdr) == ((cadr values) sCdr))
when sFunction
((car values) sTag) == ((cadr values) sTag)
else false
else false)
defPrimitive "eqv?", 2, (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) sValue) == ((cadr values) sValue)
when sPair
(((car values) sCar) == ((cadr values) sCar) and
((car values) sCdr) == ((cadr values) sCdr))
when sFunction
((car values) sTag) == ((cadr values) sTag)
else false
else false)
module.exports = (ast, kont) -> module.exports = (ast, kont) ->
evaluate ast, env_global, mem_global, (value, mem) -> interpreter = new Interpreter()
kont (transcodeBack value, mem) (meaning ast) @interpreter.env_init, (value, store_final) ->
kont (convert value, store_final)

View File

@ -72,25 +72,28 @@ makeReadPair = (delim, type) ->
return obj if obj instanceof ReadError return obj if obj instanceof ReadError
if inStream.done() then return new ReadError "Unexpected end of input" if inStream.done() then return new ReadError "Unexpected end of input"
if dotted then return new ReadError "More than one symbol after dot in list" if dotted then return new ReadError "More than one symbol after dot in list"
if obj instanceof Symbol and obj.name == '.' if @acc(obj) instanceof Symbol and @acc(obj).name == '.'
dotted = true dotted = true
return readEachPair inStream return readEachPair inStream
cons obj, readEachPair inStream cons obj, readEachPair inStream
obj = readEachPair(inStream) obj = readEachPair(inStream)
inStream.next() inStream.next()
if type then cons((new Symbol type), obj) else obj if type then cons((new Symbol type), obj) else obj
# Type -> IO -> IO, Node # Type -> IO -> IO, Node
prefixReader = (type) ->
# IO -> IO, Node
(inStream) ->
inStream.next()
obj = read inStream, true, null, true
return obj if obj instanceof ReadError
cons((new Symbol type), obj)
class Reader class Reader
prefixReader = (type) ->
# IO -> IO, Node
(inStream) ->
inStream.next()
obj = @read inStream, true, null, true
return obj if obj instanceof ReadError
cons((new Symbol type), obj)
"acc": (obj) -> obj
"symbol": (inStream) -> "symbol": (inStream) ->
symbol = (until (inStream.done() or @[inStream.peek()]? or inStream.peek() in WHITESPACE) symbol = (until (inStream.done() or @[inStream.peek()]? or inStream.peek() in WHITESPACE)
inStream.next()).join '' inStream.next()).join ''
@ -101,9 +104,9 @@ class Reader
"read": (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, keepComments = false) -> "read": (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, keepComments = false) ->
inStream = if inStream instanceof Source then inStream else new Source inStream inStream = if inStream instanceof Source then inStream else new Source inStream
c = inStream.peek() c = inStream.peek()
# (IO, Char) -> (IO, Node) | Error # (IO, Char) -> (IO, Node) | Error
matcher = (inStream, c) => matcher = (inStream, c) =>
if inStream.done() if inStream.done()
@ -116,7 +119,7 @@ class Reader
ret = if @[c]? then @[c](inStream) else @symbol(inStream) ret = if @[c]? then @[c](inStream) else @symbol(inStream)
skipWS inStream skipWS inStream
ret ret
while true while true
form = matcher inStream, c form = matcher inStream, c
skip = (not nilp form) and (form instanceof Comment) and not keepComments skip = (not nilp form) and (form instanceof Comment) and not keepComments
@ -161,7 +164,7 @@ class Reader
new Comment r new Comment r
exports.Source = Source exports.Source = Source
exports.ReadError = ReadError exports.ReadError = ReadError
exports.Reader = Reader exports.Reader = Reader
reader = new Reader() reader = new Reader()
exports.read = -> reader.read.apply(reader, arguments) exports.read = -> reader.read.apply(reader, arguments)

View File

@ -3,25 +3,37 @@
{Symbol, Comment} = require './reader_types' {Symbol, Comment} = require './reader_types'
exports.normalize = normalize = (form) -> class Normalize
return nil if nilp form normalize: (form) ->
return nil if nilp form
methods = if (pairp form)
'vector': (form) -> if (car form) instanceof Symbol and (car form).name in ['vector', 'record']
until (nilp form) then p = normalize(car form); form = cdr form; p @[(car form).name](cdr form)
else
'record': (form) -> @list form
o = Object.create(null)
until (nilp form)
o[(normalize car form)] = (normalize car cdr form)
form = cdr cdr form
null
o
if (listp form) and (car form) instanceof Symbol
if (car form).name in ['vector', 'record']
methods[(car form).name](cdr form)
else else
cons (normalize car form), (normalize cdr form) form
else
form list: (form) ->
handle = (form) =>
return nil if nilp form
if not pairp form
return @normalize form
cons (@normalize car form), (handle cdr form)
handle form
vector: (form) ->
until (nilp form) then p = @normalize(car form); form = cdr form; p
record: (form) ->
o = Object.create(null)
until (nilp form)
o[(@normalize car form)] = (@normalize car cdr form)
form = cdr cdr form
null
o
exports.Normalize = Normalize
normalize = new Normalize()
exports.normalize = -> normalize.normalize.apply(normalize, arguments)

View File

@ -1,37 +1,14 @@
{car, cdr, cons, listp, nilp, nil, {Node} = require './reader_types'
list, pairp, listToString} = require 'cons-lists/lists' {Normalize} = require './reader_rawtoform'
{Symbol, Comment} = require './reader_types' liftToNode = (f) ->
(form) ->
return f.call this, (if (form instanceof Node) then form.v else form)
exports.normalize = normalize = (form) -> NodeNormalize = class
_normalize = (form) -> for own key, func of Normalize::
return nil if nilp form.v NodeNormalize::[key] = liftToNode(func)
methods =
'vector': (form) ->
until (nilp form.v) then p = normalize(car form.v); form = cdr form.v; p
'record': (form) ->
o = Object.create(null)
until (nilp form.v)
o[(normalize car form.v)] = (normalize car cdr form.v)
form = cdr cdr form.v
null
o
'list': (form) -> exports.Normalize = NodeNormalize
handle = (form) -> normalize = new NodeNormalize()
return nil if (nilp form) exports.normalize = -> normalize.normalize.apply(normalize, arguments)
return _normalize(form) if not (listp form)
cons (_normalize car form), (handle cdr form)
handle(form.v)
if (listp form.v)
if (car form.v) instanceof Symbol and (car form.v).name in ['vector', 'record']
methods[(car form.v).name](cdr form.v)
else
methods.list(form)
else
form.v
_normalize(form)

View File

@ -13,10 +13,13 @@ liftToTrack = (f) ->
if obj instanceof Node then obj else new Node obj, line, column if obj instanceof Node then obj else new Node obj, line, column
TrackingReader = class TrackingReader = class
for own key, func of Reader:: for own key, func of Reader::
TrackingReader::[key] = liftToTrack(func) TrackingReader::[key] = liftToTrack(func)
TrackingReader::acc = (obj) -> obj.v
exports.ReadError = ReadError exports.ReadError = ReadError
exports.Reader = TrackingReader exports.Reader = TrackingReader
exports.reader = reader = new TrackingReader() exports.reader = reader = new TrackingReader()
exports.read = -> reader.read.apply(reader, arguments) exports.read = -> reader.read.apply(reader, arguments)

View File

@ -10,12 +10,15 @@ exports.samples = [
['(1 2)', cons(1, (cons 2))] ['(1 2)', cons(1, (cons 2))]
['(1 2 )', cons(1, (cons 2))] ['(1 2 )', cons(1, (cons 2))]
['( 1 2 )', cons(1, (cons 2))] ['( 1 2 )', cons(1, (cons 2))]
['(1 (2 3) 4)', cons(1, cons(cons(2, cons(3)), cons(4)))]
['( 1 2 )', cons(1, (cons 2))] ['( 1 2 )', cons(1, (cons 2))]
['("a" "b")', cons("a", (cons "b"))] ['("a" "b")', cons("a", (cons "b"))]
['("a" . "b")', cons("a", "b")] ['("a" . "b")', cons("a", "b")]
['[]', []] ['[]', []]
['{}', {}] ['{}', {}]
['{"a" [1 2 3] "b" {"c" "d"} "c" ("a" "b" . "c")}', {"a": [1,2,3], "b":{"c": "d"}, "c": cons("a", cons("b", "c"))}]
['[1 2 3]', [1, 2, 3]] ['[1 2 3]', [1, 2, 3]]
['[1 2 [3 4] 5]', [1, 2, [3, 4], 5]]
# ['(1 2 3', 'error'] # ['(1 2 3', 'error']
['{"foo" "bar"}', {foo: "bar"}] ['{"foo" "bar"}', {foo: "bar"}]
] ]

View File

@ -0,0 +1,37 @@
chai = require 'chai'
chai.should()
expect = chai.expect
olisp = require '../chapter5/interpreter5a'
{read} = require '../chapter5/reader'
lisp = (ast) ->
ret = undefined
olisp ast, (i) -> ret = i
return ret
benchmark = [
"(begin",
" (set! primes",
" (lambda (n f max)",
" ((lambda (filter)",
" (begin",
" (set! filter (lambda (p)",
" (lambda (n) (= 0 (remainder n p))) ))",
" (if (> n max)",
" '()",
" (if (f n)",
" (primes (+ n 1) f max)",
" (cons n",
" ((lambda (ff)",
" (primes (+ n 1)",
" (lambda (p) (if (f p) t (ff p)))",
" max ) )",
" (filter n) ) ) ) ) ) )",
" 'wait ) ) )",
" (primes 2 (lambda (x) f) 50) )"].join('')
describe "Chapter 5: It runs.", ->
it "Runs the primes search example", ->
expect(lisp read benchmark).to.equal(true)