Hey, it runs the test. It doesn't return the right value, but...
This commit is contained in:
parent
db2e93b2f3
commit
e0b6b44178
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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"}]
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
Loading…
Reference in New Issue