[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) '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

View File

@ -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)

View File

@ -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

View File

@ -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", ->