elf
/
LispInSmallPieces
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Frantically fitting. This isn't elegant.

This commit is contained in:
Elf M. Sternberg 2015-08-16 11:31:52 -07:00
parent ea522f6cf6
commit d49f07911c
1 changed files with 66 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
chapter4/interpreter.coffee
View File

@ -1,8 +1,12 @@
{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"
{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'
{inspect} = require 'util'
itap = (a) -> return inspect a, true, null, false
class LispInterpreterError extends Error class LispInterpreterError extends Error
name: 'LispInterpreterError' name: 'LispInterpreterError'
@ -28,22 +32,27 @@ astSymbolsToLispSymbols = (node) ->
cadddr = metacadr('cadddr') cadddr = metacadr('cadddr')
intlistp = (node) -> node.type == 'list' intlistp = (node) -> node.type == 'list'
intsymbolp = (node) -> node.type == 'symbol' intpairp = (node) -> node.type == 'list' and ((node.value.length < 2) or node.value[1].node.type != 'list')
intsymbolp = (node) -> node.type == 'symbol' or node instanceof Symbol
intnumberp = (node) -> node.type == 'number' intnumberp = (node) -> node.type == 'number'
intstringp = (node) -> node.type == 'string' intstringp = (node) -> node.type == 'string'
intcommentp = (node) -> node.type == 'comment' intcommentp = (node) -> node.type == 'comment'
intnvalu = (node) -> if (node.type == 'symbol') then node.value.name else node.value intnvalu = (node) -> node.value
intatomp = (node) -> node.type in ['symbol', 'number', 'string'] intatomp = (node) -> node.type in ['symbol', 'number', 'string']
intnullp = (node) -> node.type == 'symbol' and node.value.name == 'null'
intmksymbols = (list) -> astSymbolsToLispSymbols(list) intmksymbols = (list) -> astSymbolsToLispSymbols(list)
# The hairness of this makes me doubt the wisdom of using Javascript. # The hairness of this makes me doubt the wisdom of using Javascript.
sBehavior = new Symbol 'behavior'
sBehavior = new Symbol 'behavior' sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean' sBoolean = new Symbol 'boolean'
sBoolify = new Symbol 'boolify' sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function' sFunction = new Symbol 'function'
sSymbol = new Symbol 'symbol'
sString = new Symbol 'string'
sChars = new Symbol 'chars'
sName = new Symbol 'name' sName = new Symbol 'name'
sNumber = new Symbol 'number'
sNull = new Symbol 'null' sNull = new Symbol 'null'
sTag = new Symbol 'tag' sTag = new Symbol 'tag'
sType = new Symbol 'type' sType = new Symbol 'type'
@ -70,35 +79,49 @@ prox =
transcode = (value, mem, qont) -> transcode = (value, mem, qont) ->
forms = [ forms = [
[intnullp, -> q theEmptyList, mem], [intnullp, -> qont theEmptyList, mem],
[((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> q (createBoolean value), mem)] [((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
[intsymbolp, (-> q (createSymbol value), mem)] [intsymbolp, (-> qont (createSymbol value), mem)]
[intnumberp, (-> q (createNumber value), mem)] [intnumberp, (-> qont (createNumber value), mem)]
[intpairp, (-> 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)))]
] ]
form = form[1] for form in forms when form[0](value) found = (form[1] for form in forms when form[0](value))
if len(form) != 1 if found.length != 1
throw new LispInterpreterError "Bad form match for #{value}" throw new LispInterpreterError "Bad transcode match for #{value}"
form[0]() found[0]()
transcodeBack = (value, mem) ->
forms = [
[sBoolean, ((v) -> ((v sBoolify) true, false))]
[sSymbol, ((v) -> (v sName))]
[sString, ((v) -> (v sChars))]
[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) -> evaluate = (exp, env, mem, kont) ->
if intatomp exp if intatomp exp
if intsymbolp exp if intsymbolp exp
evaluateVariable exp, env, mem, kont evaluateVariable (intnvalu exp), env, mem, kont
else else
evaluateQuote exp, env, mem, kont evaluateQuote exp, env, mem, kont
else else
body = intnvalu exp body = intnvalu exp
head = car body head = car body
if prox[(intnvalu head)]? if prox[(intnvalu head)]?
prox[(intnvalu head)](body, env, mem, kont, ix) prox[(intnvalu head)](body, env, mem, kont)
else else
evaluateApplication body, (cadr body), env, mem, kont evaluateApplication head, (cdr body), env, mem, kont
env_init = (id) -> throw LispInterpreterError "No binding for #{id}" env_init = (id) -> throw new LispInterpreterError "No binding for " + id.toString()
# 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
@ -177,7 +200,7 @@ 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 (normalizeForms c), mem, kont transcode (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
@ -210,7 +233,7 @@ createBoolean = (value) ->
createSymbol = (value) -> createSymbol = (value) ->
(msg) -> (msg) ->
switch msg switch msg
when sType then sValue when sType then sSymbol
when sName then value when sName then value
when sBoolify then (x, y) -> x when sBoolify then (x, y) -> x
@ -224,7 +247,7 @@ createNumber = (value) ->
createFunction = (tag, behavior) -> createFunction = (tag, behavior) ->
(msg) -> (msg) ->
switch msg switch msg
when sType then sNumber when sType then sFunction
when sBoolify then (x, y) -> x when sBoolify then (x, y) -> x
when sTag then tag when sTag then tag
when sBehavior then behavior when sBehavior then behavior
@ -281,15 +304,17 @@ mem_global = mem_init
# corresponding boxed value. # corresponding boxed value.
defInitial = (name, value) -> defInitial = (name, value) ->
if typeof name == 'string'
name = new Symbol name
allocate 1, mem_global, (addrs, mem2) -> allocate 1, mem_global, (addrs, mem2) ->
env_global = update env_global, (new Symbol name), (car addrs) env_global = update env_global, name, (car addrs)
mem_global = update mem2, (car addrs), value mem_global = update mem2, (car addrs), value
defPrimitive = (name, arity, value) -> defPrimitive = (name, arity, value) ->
defInitial name, allocate 1, mem_global, (addrs, mem2) -> defInitial name, allocate 1, mem_global, (addrs, mem2) ->
mem_global = expandStore (car addrs), mem2 mem_global = expandStore (car addrs), mem2
createFunction (car addrs), (values, mem, kont) -> createFunction (car addrs), (values, mem, kont) ->
if (eq arity (length values)) if (eq arity, (length values))
value values, mem, kont value values, mem, kont
else else
throw new LispInterpreterError "Wrong arity for #{name}" throw new LispInterpreterError "Wrong arity for #{name}"
@ -388,7 +413,7 @@ defPrimitive "setcar", 2, (values, mem, kont) ->
else else
throw new LispInterpreterError "Not a pair" throw new LispInterpreterError "Not a pair"
defPrimitive "eqv?", (values, mem, kont) -> defPrimitive "eqv?", 2, (values, mem, kont) ->
kont createBoolean ( kont createBoolean (
if (eq ((car values) sType) ((cadr values) sType)) if (eq ((car values) sType) ((cadr values) sType))
switch ((car values) sType) switch ((car values) sType)
@ -406,5 +431,22 @@ defPrimitive "eqv?", (values, mem, kont) ->
else false else false
else false) else false)
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 value) sTag) == ((cadr value) sTag)
else false
else false)
module.exports = (ast, kont) -> module.exports = (ast, kont) ->
evaluate ast, env_global, mem_global, kont evaluate ast, env_global, mem_global, (value, mem) ->
kont (transcodeBack value, mem)