[feat] Chapter 4 is done.
This commit is contained in:
parent
d49f07911c
commit
00fbe22583
|
@ -26,7 +26,7 @@ normalizeForm = (form) ->
|
||||||
'record': (atom) -> listToRecord1(atom)
|
'record': (atom) -> listToRecord1(atom)
|
||||||
|
|
||||||
# Basic native types. Meh.
|
# Basic native types. Meh.
|
||||||
'symbol': (id) -> new Symbol(id)
|
'symbol': (id) -> new Symbol(id.name)
|
||||||
'number': id
|
'number': id
|
||||||
'string': id
|
'string': id
|
||||||
'nil': (atom) -> nil
|
'nil': (atom) -> nil
|
||||||
|
|
|
@ -50,7 +50,7 @@ sBoolify = new Symbol 'boolify'
|
||||||
sFunction = new Symbol 'function'
|
sFunction = new Symbol 'function'
|
||||||
sSymbol = new Symbol 'symbol'
|
sSymbol = new Symbol 'symbol'
|
||||||
sString = new Symbol 'string'
|
sString = new Symbol 'string'
|
||||||
sChars = new Symbol 'chars'
|
sValue = new Symbol 'chars'
|
||||||
sName = new Symbol 'name'
|
sName = new Symbol 'name'
|
||||||
sNumber = new Symbol 'number'
|
sNumber = new Symbol 'number'
|
||||||
sNull = new Symbol 'null'
|
sNull = new Symbol 'null'
|
||||||
|
@ -69,7 +69,7 @@ prox =
|
||||||
"begin": (body, env, mem, kont) -> evaluateBegin (cdr 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
|
"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
|
"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
|
"or": (body, env, mem, kont) -> evaluateOr (cadr body), (caddr body), env, mem, kont
|
||||||
|
|
||||||
# ___ _ _
|
# ___ _ _
|
||||||
# | __|_ ____ _| |_ _ __ _| |_ ___ _ _
|
# | __|_ ____ _| |_ _ __ _| |_ ___ _ _
|
||||||
|
@ -83,6 +83,7 @@ transcode = (value, mem, qont) ->
|
||||||
[((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
|
[((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
|
||||||
[intsymbolp, (-> qont (createSymbol value), mem)]
|
[intsymbolp, (-> qont (createSymbol value), mem)]
|
||||||
[intnumberp, (-> qont (createNumber value), mem)]
|
[intnumberp, (-> qont (createNumber value), mem)]
|
||||||
|
[intstringp, (-> qont (createString value), mem)]
|
||||||
[intlistp, (-> transcode (car intnvalu value), mem, (addr, mem2) ->
|
[intlistp, (-> transcode (car intnvalu value), mem, (addr, mem2) ->
|
||||||
(transcode (cdr intvalu value), mem2, (d, mem3) ->
|
(transcode (cdr intvalu value), mem2, (d, mem3) ->
|
||||||
(allocatePair addr, d, mem3, qont)))]
|
(allocatePair addr, d, mem3, qont)))]
|
||||||
|
@ -92,11 +93,28 @@ transcode = (value, mem, qont) ->
|
||||||
throw new LispInterpreterError "Bad transcode match for #{value}"
|
throw new LispInterpreterError "Bad transcode match for #{value}"
|
||||||
found[0]()
|
found[0]()
|
||||||
|
|
||||||
|
transcode2 = (value, mem, qont) ->
|
||||||
|
forms = [
|
||||||
|
[((v) -> v instanceof Symbol and v.name == 'null'), (-> qont theEmptyList, mem)],
|
||||||
|
[((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]()
|
||||||
|
|
||||||
|
|
||||||
transcodeBack = (value, mem) ->
|
transcodeBack = (value, mem) ->
|
||||||
forms = [
|
forms = [
|
||||||
[sBoolean, ((v) -> ((v sBoolify) true, false))]
|
[sBoolean, ((v) -> ((v sBoolify) true, false))]
|
||||||
[sSymbol, ((v) -> (v sName))]
|
[sSymbol, ((v) -> (v sName))]
|
||||||
[sString, ((v) -> (v sChars))]
|
[sString, ((v) -> (v sValue))]
|
||||||
[sNumber, ((v) -> (v sValue))]
|
[sNumber, ((v) -> (v sValue))]
|
||||||
[sPair, ((v) ->
|
[sPair, ((v) ->
|
||||||
cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
|
cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
|
||||||
|
@ -116,12 +134,14 @@ evaluate = (exp, env, mem, kont) ->
|
||||||
else
|
else
|
||||||
body = intnvalu exp
|
body = intnvalu exp
|
||||||
head = car body
|
head = car body
|
||||||
if prox[(intnvalu head)]?
|
pname = (intnvalu head)
|
||||||
prox[(intnvalu head)](body, env, mem, kont)
|
if pname instanceof Symbol and prox[pname.name]?
|
||||||
|
prox[pname.name](body, env, mem, kont)
|
||||||
else
|
else
|
||||||
evaluateApplication head, (cdr body), env, mem, kont
|
evaluateApplication head, (cdr body), env, mem, kont
|
||||||
|
|
||||||
env_init = (id) -> throw new LispInterpreterError "No binding for " + id.toString()
|
env_init = (id) ->
|
||||||
|
throw new LispInterpreterError "No binding for " + id
|
||||||
|
|
||||||
# This is basically the core definition of 'mem': it returns a
|
# This is basically the core definition of 'mem': it returns a
|
||||||
# function enclosing the address (a monotomically increasing number as
|
# function enclosing the address (a monotomically increasing number as
|
||||||
|
@ -200,14 +220,14 @@ evaluateIf = (expc, expt, expf, env, mem, kont) ->
|
||||||
evaluate ((env sBoolify) expt, expf), env, mems, kont
|
evaluate ((env sBoolify) expt, expf), env, mems, kont
|
||||||
|
|
||||||
evaluateQuote = (c, env, mem, kont) ->
|
evaluateQuote = (c, env, mem, kont) ->
|
||||||
transcode (normalizeForm c), mem, kont
|
transcode2 (normalizeForm c), mem, kont
|
||||||
|
|
||||||
# By starting over "from here," we undo all side-effect assignments
|
# By starting over "from here," we undo all side-effect assignments
|
||||||
# that were effected by expression 1
|
# that were effected by expression 1
|
||||||
|
|
||||||
evaluateOr = (exp1, exp2, env, mem, kont) ->
|
evaluateOr = (exp1, exp2, env, mem, kont) ->
|
||||||
evaluate exp1, env, mem, (value, mem2) ->
|
evaluate exp1, env, mem, (value, mem2) ->
|
||||||
(value sBoolify) (-> kont value, mem2), (-> evaluate exp2, env, mem, kont)
|
((value sBoolify) (-> kont value, mem2), (-> evaluate exp2, env, mem, kont))()
|
||||||
|
|
||||||
# I like how, in this version, we explicitly throw away the meaning of
|
# I like how, in this version, we explicitly throw away the meaning of
|
||||||
# all but the last statement in evaluateBegin.
|
# all but the last statement in evaluateBegin.
|
||||||
|
@ -244,6 +264,13 @@ createNumber = (value) ->
|
||||||
when sValue then value
|
when sValue then value
|
||||||
when sBoolify then (x, y) -> x
|
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) ->
|
createFunction = (tag, behavior) ->
|
||||||
(msg) ->
|
(msg) ->
|
||||||
switch msg
|
switch msg
|
||||||
|
@ -326,8 +353,8 @@ defPrimitive = (name, arity, value) ->
|
||||||
#
|
#
|
||||||
|
|
||||||
|
|
||||||
defInitial "true", createBoolean true
|
defInitial "#t", createBoolean true
|
||||||
defInitial "false", createBoolean false
|
defInitial "#f", createBoolean false
|
||||||
defInitial "nil", null
|
defInitial "nil", null
|
||||||
|
|
||||||
defPrimitive "<=", 2, (values, mem, kont) ->
|
defPrimitive "<=", 2, (values, mem, kont) ->
|
||||||
|
@ -355,7 +382,7 @@ defPrimitive ">", 2, (values, mem, kont) ->
|
||||||
throw new LispInterpreterError "Comparison requires numbers"
|
throw new LispInterpreterError "Comparison requires numbers"
|
||||||
|
|
||||||
defPrimitive "=", 2, (values, mem, kont) ->
|
defPrimitive "=", 2, (values, mem, kont) ->
|
||||||
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
|
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sType), sNumber)
|
||||||
kont (createBoolean (((car values) sValue) == ((cadr values) sValue))), mem
|
kont (createBoolean (((car values) sValue) == ((cadr values) sValue))), mem
|
||||||
else
|
else
|
||||||
throw new LispInterpreterError "Comparison requires numbers"
|
throw new LispInterpreterError "Comparison requires numbers"
|
||||||
|
@ -367,7 +394,7 @@ defPrimitive "*", 2, (values, mem, kont) ->
|
||||||
throw new LispInterpreterError "Multiplication requires numbers"
|
throw new LispInterpreterError "Multiplication requires numbers"
|
||||||
|
|
||||||
defPrimitive "+", 2, (values, mem, kont) ->
|
defPrimitive "+", 2, (values, mem, kont) ->
|
||||||
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
|
if (eq ((car values) sType), sNumber) and (eq ((cadr values) sType), sNumber)
|
||||||
kont (createNumber (((car values) sValue) + ((cadr values) sValue))), mem
|
kont (createNumber (((car values) sValue) + ((cadr values) sValue))), mem
|
||||||
else
|
else
|
||||||
throw new LispInterpreterError "Addition requires numbers"
|
throw new LispInterpreterError "Addition requires numbers"
|
||||||
|
@ -413,24 +440,6 @@ defPrimitive "setcar", 2, (values, mem, kont) ->
|
||||||
else
|
else
|
||||||
throw new LispInterpreterError "Not a pair"
|
throw new LispInterpreterError "Not a pair"
|
||||||
|
|
||||||
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) 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)
|
|
||||||
|
|
||||||
defPrimitive "eq?", 2, (values, mem, kont) ->
|
defPrimitive "eq?", 2, (values, mem, kont) ->
|
||||||
kont createBoolean (
|
kont createBoolean (
|
||||||
if (eq ((car values) sType), ((cadr values) sType))
|
if (eq ((car values) sType), ((cadr values) sType))
|
||||||
|
@ -443,7 +452,25 @@ defPrimitive "eq?", 2, (values, mem, kont) ->
|
||||||
(((car values) sCar) == ((cadr values) sCar) and
|
(((car values) sCar) == ((cadr values) sCar) and
|
||||||
((car values) sCdr) == ((cadr values) sCdr))
|
((car values) sCdr) == ((cadr values) sCdr))
|
||||||
when sFunction
|
when sFunction
|
||||||
((car value) sTag) == ((cadr value) sTag)
|
((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
|
||||||
else false)
|
else false)
|
||||||
|
|
||||||
|
|
|
@ -126,7 +126,7 @@ prefixReader = (type) ->
|
||||||
[line1, column1] = inStream.position()
|
[line1, column1] = inStream.position()
|
||||||
obj = read inStream, true, null, true
|
obj = read inStream, true, null, true
|
||||||
return obj if obj.type == 'error'
|
return obj if obj.type == 'error'
|
||||||
new Node "list", cons((new Node("symbol", type, line1, column1)), cons(obj)), line, column
|
new Node "list", cons((new Node("symbol", (new Symbol type), line1, column1)), cons(obj)), line, column
|
||||||
|
|
||||||
# I really wanted to make anything more complex than a list (like an
|
# I really wanted to make anything more complex than a list (like an
|
||||||
# object or a vector) something handled by a read macro. Maybe in a
|
# object or a vector) something handled by a read macro. Maybe in a
|
||||||
|
|
|
@ -14,12 +14,15 @@ lisp = (ast) ->
|
||||||
return ret
|
return ret
|
||||||
|
|
||||||
describe "Core interpreter #4: Pure Lambda Memory", ->
|
describe "Core interpreter #4: Pure Lambda Memory", ->
|
||||||
it "Understands equality", ->
|
it "Understands symbol equality", ->
|
||||||
expect(lisp read "(eq? 'a 'b)").to.equal(false)
|
expect(lisp read "(eq? 'a 'b)").to.equal(false)
|
||||||
expect(lisp read "(eq? 'a 'a)").to.equal(true)
|
expect(lisp read "(eq? 'a 'a)").to.equal(true)
|
||||||
|
it "Understands separate allocation inequality", ->
|
||||||
expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
|
expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
|
||||||
|
it "Understands address equality", ->
|
||||||
expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true)
|
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 "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true)
|
||||||
|
it "Understands function inequality", ->
|
||||||
expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
|
expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
|
||||||
|
|
||||||
it "Understands equivalence", ->
|
it "Understands equivalence", ->
|
||||||
|
|
Loading…
Reference in New Issue