Start of chapter 5 interpreters. New readers, too.

This commit is contained in:
Elf M. Sternberg 2015-08-18 07:09:47 -07:00
parent 00fbe22583
commit 981baec645
3 changed files with 693 additions and 0 deletions

View File

@ -0,0 +1,479 @@
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
metacadr, setcar} = require "cons-lists/lists"
{length} = require "cons-lists/reduce"
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
{Node, Comment, Symbol} = require '../chapter1/reader_types'
{inspect} = require 'util'
itap = (a) -> return inspect a, true, null, false
class LispInterpreterError extends Error
name: 'LispInterpreterError'
constructor: (@message) ->
the_false_value = (cons "false", "boolean")
eq = (id1, id2) ->
if id1 instanceof Symbol and id2 instanceof Symbol
return id1.name == id2.name
id1 == id2
# Only called in rich node mode...
astSymbolsToLispSymbols = (node) ->
return nil if nilp node
throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
handler = (cell) ->
return nil if nilp cell
cons (car cell).value, (handler cdr cell)
handler node.value
cadddr = metacadr('cadddr')
intlistp = (node) -> node.type == 'list'
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'
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.
sBehavior = new Symbol 'behavior'
sBoolean = new Symbol 'boolean'
sBoolify = new Symbol 'boolify'
sFunction = new Symbol 'function'
sSymbol = new Symbol 'symbol'
sString = new Symbol 'string'
sValue = new Symbol 'chars'
sName = new Symbol 'name'
sNumber = new Symbol 'number'
sNull = new Symbol 'null'
sTag = new Symbol 'tag'
sType = new Symbol 'type'
sValue = new Symbol 'value'
sPair = new Symbol 'pair'
sCar = new Symbol 'car'
sCdr = new Symbol 'cdr'
sSetCar = new Symbol 'setcar'
sSetCdr = new Symbol 'setcdr'
prox =
"quote": (body, env, mem, kont) -> evaluateQuote (cadr body), env, mem, kont
"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
# ___ _ _
# | __|_ ____ _| |_ _ __ _| |_ ___ _ _
# | _|\ V / _` | | || / _` | _/ _ \ '_|
# |___|\_/\__,_|_|\_,_\__,_|\__\___/_|
#
transcode = (value, mem, qont) ->
forms = [
[intnullp, -> qont theEmptyList, mem],
[((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) ->
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 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
# each other. Here, all of the continuations are kept in one place,
# and the argument list is built by tail-calls to evaluateArguments
# until the list is exhausted, at which point the continuation is
# called. The continuation is built in the second paragraph below.
evaluateArguments = (exprs, env, mem, kont) ->
if (pairp exprs)
evaluate (car exprs), env, mem, (value, mem2) ->
evaluateArguments (cdr exprs), env, mem2, (value2, mem3) ->
kont (cons value, value2), mem3
else
kont cons(), mem
evaluate exp, env, mem, (fun, mem2) ->
evaluateArguments exprs, env, mem2, (value2, mem3) ->
if eq (fun sType), sFunction
(fun sBehavior) value2, mem3, kont
else
throw new LispInterpreterError "Not a function #{(car value2)}"
# Creates a memory address for the function, then creates a new memory
# address for each argument, then evaluates the expressions in the
# lambda, returning the value of the last one.
evaluateLambda = (names, exprs, env, mem, kont) ->
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) ->
evaluate expc, env, mem, (env, mems) ->
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
q theEmptyList, mem
consify values, q
allocatePair = (addr, d, mem, q) ->
allocate 2, mem, (addrs, mem2) ->
q (createPair (car addrs), (cadr addrs)), (update (update mem2, (car addrs), addr), (cadr addrs), d)
createPair = (a, d) ->
(msg) ->
switch msg
when sType then sPair
when sBoolify then (x, y) -> x
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
mem_global = mem_init
# The name is pushed onto the global environment, with a corresponding
# address. The address is pushed onto the current memory, with the
# corresponding boxed value.
defInitial = (name, value) ->
if typeof name == 'string'
name = new Symbol name
allocate 1, mem_global, (addrs, mem2) ->
env_global = update env_global, name, (car addrs)
mem_global = update mem2, (car addrs), value
defPrimitive = (name, arity, value) ->
defInitial name, allocate 1, mem_global, (addrs, mem2) ->
mem_global = expandStore (car addrs), mem2
createFunction (car addrs), (values, mem, kont) ->
if (eq arity, (length values))
value values, mem, kont
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) ->
evaluate ast, env_global, mem_global, (value, mem) ->
kont (transcodeBack value, mem)

203
chapter5/reader.coffee Normal file
View File

@ -0,0 +1,203 @@
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
{inspect} = require "util"
{Node, Comment, Symbol} = require "../chapter5/reader_types"
NEWLINES = ["\n", "\r", "\x0B", "\x0C"]
WHITESPACE = [" ", "\t"].concat(NEWLINES)
EOF = new (class Eof)()
EOO = new (class Eoo)()
class Source
constructor: (@inStream) ->
@index = 0
@max = @inStream.length - 1
@line = 0
@column = 0
peek: -> @inStream[@index]
position: -> [@line, @column]
next: ->
c = @peek()
return EOF if @done()
@index++
[@line, @column] = if @peek() in NEWLINES then [@line + 1, 0] else [@line, @column + 1]
c
done: -> @index > @max
# IO -> IO
skipWS = (inStream) ->
while inStream.peek() in WHITESPACE then inStream.next()
# msg -> (IO -> IO, Node)
handleError = (message) ->
(line, column) -> new Node('error', message, line, column)
# IO -> (IO, Node)
readComment = (inStream) ->
[line, column] = inStream.position()
r = (while inStream.peek() != "\n" and not inStream.done()
inStream.next()).join("")
if not inStream.done()
inStream.next()
new Node 'comment', (new Comment r), line, column
# IO -> (IO, Node) | Error
readString = (inStream) ->
[line, column] = inStream.position()
inStream.next()
string = until inStream.peek() == '"' or inStream.done()
if inStream.peek() == '\\'
inStream.next()
inStream.next()
if inStream.done()
return handleError("end of file seen before end of string.")(line, column)
inStream.next()
new Node 'string', (string.join ''), line, column
# (String) -> (Symbol | Number) | Nothing
readMaybeNumber = (symbol) ->
if symbol[0] == '+'
return readMaybeNumber symbol.substr(1)
if symbol[0] == '-'
ret = readMaybeNumber symbol.substr(1)
return if ret? then -1 * ret else undefined
if symbol.search(/^0x[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 16)
if symbol.search(/^0[0-9a-fA-F]+$/) > -1
return parseInt(symbol, 8)
if symbol.search(/^[0-9]+$/) > -1
return parseInt(symbol, 10)
if symbol.search(/^nil$/) > -1
return nil
undefined
# (IO, macros) -> (IO, Node => Number | Symbol) | Error
readSymbol = (inStream, tableKeys) ->
[line, column] = inStream.position()
symbol = (until (inStream.done() or inStream.peek() in tableKeys or inStream.peek() in WHITESPACE)
inStream.next()).join ''
number = readMaybeNumber symbol
if number?
return new Node 'number', number, line, column
new Node (new Symbol symbol), line, column
# (Delim, TypeName) -> IO -> (IO, Node) | Error
makeReadPair = (delim, type) ->
# IO -> (IO, Node) | Error
(inStream) ->
inStream.next()
skipWS inStream
[line, column] = inStream.position()
if inStream.peek() == delim
inStream.next()
return new Node type, nil, line, column
# IO -> (IO, Node) | Error
dotted = false
readEachPair = (inStream) ->
[line, column] = inStream.position()
obj = read inStream, true, null, true
if inStream.peek() == delim
if dotted then return obj
return cons obj, nil
if inStream.done() then return handleError("Unexpected end of input")(line, column)
if dotted then return handleError("More than one symbol after dot")
return obj if obj.type == 'error'
if obj.type == 'symbol' and obj.value == '.'
dotted = true
return readEachPair inStream
cons obj, readEachPair inStream
ret = new Node type, readEachPair(inStream), line, column
inStream.next()
ret
# Type -> IO -> IO, Node
prefixReader = (type) ->
# IO -> IO, Node
(inStream) ->
[line, column] = inStream.position()
inStream.next()
[line1, column1] = inStream.position()
obj = read inStream, true, null, true
return obj if obj.type == 'error'
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
# future revision I can vertically de-integrate these.
readMacros =
'"': readString
'(': makeReadPair ')', 'list'
')': handleError "Closing paren encountered"
'[': makeReadPair ']', 'vector'
']': handleError "Closing bracket encountered"
'{': makeReadPair('}', 'record', (res) ->
res.length % 2 == 0 and true or mkerr "record key without value")
'}': handleError "Closing curly without corresponding opening."
"`": prefixReader 'back-quote'
"'": prefixReader 'quote'
",": prefixReader 'unquote'
";": readComment
# Given a stream, reads from the stream until a single complete lisp
# object has been found and returns the object
# IO -> IO, Node
read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadMacros = null, keepComments = false) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
inReadMacros = if InReadMacros? then inReadMacros else readMacros
inReadMacroKeys = (i for i of inReadMacros)
c = inStream.peek()
# (IO, Char) -> (IO, Node) | Error
matcher = (inStream, c) ->
if inStream.done()
return if recursiveP then handleError('EOF while processing nested object')(inStream) else nil
if c in WHITESPACE
inStream.next()
return nil
if c == ';'
return readComment(inStream)
ret = if c in inReadMacroKeys then inReadMacros[c](inStream) else readSymbol(inStream, inReadMacroKeys)
skipWS inStream
ret
while true
form = matcher inStream, c
skip = (not nilp form) and (form.type == 'comment') and not keepComments
break if (not skip and not nilp form) or inStream.done()
c = inStream.peek()
null
form
# readForms assumes that the string provided contains zero or more
# forms. As such, it always returns a list of zero or more forms.
# IO -> (IO, Nodes* | Error)
readForms = (inStream) ->
inStream = if inStream instanceof Source then inStream else new Source inStream
return nil if inStream.done()
# IO -> (IO, Nodes* | Error
[line, column] = inStream.position()
readEach = (inStream) ->
obj = read inStream, true, null, false
return nil if (nilp obj)
return obj if obj.type == 'error'
cons obj, readEach inStream
obj = readEach inStream
if obj.type == 'error' then obj else new Node "list", obj, line, column
exports.read = read
exports.readForms = readForms
exports.Node = Node
exports.Symbol = Symbol

View File

@ -0,0 +1,11 @@
exports.Node = class
constructor: (@v, @line, @column) ->
exports.Symbol = class
constructor: (@name) ->
exports.Comment = class
constructor: (@text) ->