[feat] Chapter 4 is done.

This commit is contained in:
Elf M. Sternberg 2015-08-16 22:21:10 -07:00
parent d49f07911c
commit 00fbe22583
4 changed files with 64 additions and 34 deletions

View File

@ -26,7 +26,7 @@ normalizeForm = (form) ->
'record': (atom) -> listToRecord1(atom)
# Basic native types. Meh.
'symbol': (id) -> new Symbol(id)
'symbol': (id) -> new Symbol(id.name)
'number': id
'string': id
'nil': (atom) -> nil

View File

@ -50,7 +50,7 @@ sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function'
sSymbol = new Symbol 'symbol'
sString = new Symbol 'string'
sChars = new Symbol 'chars'
sValue = new Symbol 'chars'
sName = new Symbol 'name'
sNumber = new Symbol 'number'
sNull = new Symbol 'null'
@ -69,7 +69,7 @@ prox =
"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
"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)]
[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)))]
@ -92,11 +93,28 @@ transcode = (value, mem, qont) ->
throw new LispInterpreterError "Bad transcode match for #{value}"
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) ->
forms = [
[sBoolean, ((v) -> ((v sBoolify) true, false))]
[sSymbol, ((v) -> (v sName))]
[sString, ((v) -> (v sChars))]
[sString, ((v) -> (v sValue))]
[sNumber, ((v) -> (v sValue))]
[sPair, ((v) ->
cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
@ -116,12 +134,14 @@ evaluate = (exp, env, mem, kont) ->
else
body = intnvalu exp
head = car body
if prox[(intnvalu head)]?
prox[(intnvalu head)](body, env, mem, kont)
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.toString()
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
@ -200,14 +220,14 @@ evaluateIf = (expc, expt, expf, env, mem, kont) ->
evaluate ((env sBoolify) expt, expf), env, mems, 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
# 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)
((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.
@ -244,6 +264,13 @@ createNumber = (value) ->
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
@ -326,8 +353,8 @@ defPrimitive = (name, arity, value) ->
#
defInitial "true", createBoolean true
defInitial "false", createBoolean false
defInitial "#t", createBoolean true
defInitial "#f", createBoolean false
defInitial "nil", null
defPrimitive "<=", 2, (values, mem, kont) ->
@ -355,7 +382,7 @@ defPrimitive ">", 2, (values, mem, kont) ->
throw new LispInterpreterError "Comparison requires numbers"
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
else
throw new LispInterpreterError "Comparison requires numbers"
@ -367,7 +394,7 @@ defPrimitive "*", 2, (values, mem, kont) ->
throw new LispInterpreterError "Multiplication requires numbers"
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
else
throw new LispInterpreterError "Addition requires numbers"
@ -413,24 +440,6 @@ defPrimitive "setcar", 2, (values, mem, kont) ->
else
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) ->
kont createBoolean (
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) sCdr) == ((cadr values) sCdr))
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)

View File

@ -126,7 +126,7 @@ prefixReader = (type) ->
[line1, column1] = inStream.position()
obj = read inStream, true, null, true
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
# object or a vector) something handled by a read macro. Maybe in a

View File

@ -14,12 +14,15 @@ lisp = (ast) ->
return ret
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 'a)").to.equal(true)
it "Understands separate allocation inequality", ->
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)) (lambda (x) x))").to.equal(true)
it "Understands function inequality", ->
expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
it "Understands equivalence", ->