Start of chapter 5 interpreters. New readers, too.
This commit is contained in:
parent
00fbe22583
commit
981baec645
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
exports.Node = class
|
||||
constructor: (@v, @line, @column) ->
|
||||
|
||||
exports.Symbol = class
|
||||
constructor: (@name) ->
|
||||
|
||||
exports.Comment = class
|
||||
constructor: (@text) ->
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue