Beginning Chapter 4.
This commit is contained in:
parent
73be7dee59
commit
1e38327b2a
|
|
@ -321,9 +321,10 @@ class CatchCont extends Continuation
|
|||
|
||||
# Resume here does just that; it just resumes with the continuation
|
||||
# passed in above. But should catch be *triggered* by a throw (and
|
||||
# the throw-continuation), we get the contents of throw as a thing to
|
||||
# be evaluated with its current environment, then continue with *this*
|
||||
# as the continuation passed to throwing-continuation.
|
||||
# the throw-continuation), we get the contents of throw as an object
|
||||
# to be evaluated with its current environment, then continue with
|
||||
# *this* as the continuation passed to throwing-continuation, which
|
||||
# resumes the catchLookup until the stack is exhausted.
|
||||
|
||||
class LabeledCont extends Continuation
|
||||
constructor: (@kont, @tag) ->
|
||||
|
|
@ -350,21 +351,13 @@ class UnwindCont extends Continuation
|
|||
resume: (value) ->
|
||||
@kont.unwind @value, @target
|
||||
|
||||
# Works its way through the stack environment stack, looking for
|
||||
# ("breaching") protected blocks to unwind, and processing them as
|
||||
# necessary. One of those will by definition be the continuation
|
||||
# passed to the catch continuation, as the throwing-continuation is
|
||||
# constructed with it as the address of the resumecont.
|
||||
|
||||
class ThrowingCont extends Continuation
|
||||
constructor: (@kont, @tag, @resumecont) ->
|
||||
@_type = "ThrowingCont"
|
||||
resume: (value) ->
|
||||
@kont.unwind value, @resumecont
|
||||
|
||||
evaluateUnwindProtect = (form, cleanup, env, kont) ->
|
||||
evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
|
||||
|
||||
# If the continuation is "resumed," it works like normal; but if its
|
||||
# "unwound," it works its way up the unwind stack looking for the
|
||||
# target continuation to which to deliver the value.
|
||||
|
||||
class UnwindProtectCont extends Continuation
|
||||
constructor: (@kont, @cleanup, @env) ->
|
||||
@_type = "UnwindProtectCont"
|
||||
|
|
@ -373,6 +366,23 @@ class UnwindProtectCont extends Continuation
|
|||
unwind: (value, target) ->
|
||||
evaluateBegin @cleanup, @env, (new UnwindCont @kont, value, target)
|
||||
|
||||
# Works its way through the stack environment stack, looking for
|
||||
# ("breaching") protected blocks to unwind, and processing them as
|
||||
# necessary. One of those will by definition be the continuation
|
||||
# passed to the catch continuation: the throwing-continuation was
|
||||
# constructed with the catch continuation itself as the address of the
|
||||
# resumecont.
|
||||
|
||||
class ThrowingCont extends Continuation
|
||||
constructor: (@kont, @tag, @resumecont) ->
|
||||
@_type = "ThrowingCont"
|
||||
resume: (value) ->
|
||||
@kont.unwind value, @resumecont
|
||||
|
||||
# Note that this behavior basically much like throwing-continuation,
|
||||
# except that it's the resumption (the next continuation), rather than
|
||||
# the rewind.
|
||||
|
||||
class ProtectReturnCont extends Continuation
|
||||
constructor: (@kont, @value) ->
|
||||
@_type = "ProtectReturnCont"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,165 @@
|
|||
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
|
||||
cadr, caadr, cadar, caddr, nilp, nil, setcdr,
|
||||
metacadr, setcar} = require "cons-lists/lists"
|
||||
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
|
||||
{Node, Symbol} = require '../chapter1/reader_types'
|
||||
|
||||
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')
|
||||
|
||||
metadata_evaluation =
|
||||
listp: (node) -> node.type == 'list'
|
||||
symbolp: (node) -> node.type == 'symbol'
|
||||
numberp: (node) -> node.type == 'number'
|
||||
stringp: (node) -> node.type == 'string'
|
||||
commentp: (node) -> node.type == 'comment'
|
||||
nvalu: (node) -> node.value
|
||||
mksymbols: (list) -> astSymbolsToLispSymbols(list)
|
||||
|
||||
# The hairness of this makes me doubt the wisdom of using Javascript.
|
||||
|
||||
straight_evaluation =
|
||||
listp: (cell) -> cell.__type == 'list'
|
||||
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
|
||||
commentp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
|
||||
numberp: (cell) -> typeof cell == 'number'
|
||||
stringp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
|
||||
boolp: (cell) -> typeof cell == 'boolean'
|
||||
nullp: (cell) -> cell == null
|
||||
vectorp: (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
|
||||
recordp: (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
|
||||
objectp: (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
|
||||
nilp: (cell) -> nilp(cell)
|
||||
nvalu: (cell) -> cell
|
||||
mksymbols: (cell) -> cell
|
||||
|
||||
sType = new Symbol 'type'
|
||||
sBehavior = new Symbol 'behavior'
|
||||
sFunction = new Symbol 'function'
|
||||
|
||||
# Page 129
|
||||
env_init = (id) -> throw LispInterpreterError "No binding for #{id}"
|
||||
|
||||
# Page 129
|
||||
# We don't have an initial value for mem yet?
|
||||
update = (mem, addr, value) ->
|
||||
(addra) -> if (addra == addr) then value else mem(addra)
|
||||
|
||||
# Page 130
|
||||
updates = (mem, addrs, values) ->
|
||||
if (pairp addrs)
|
||||
updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values)
|
||||
else
|
||||
mem
|
||||
|
||||
# Page 130
|
||||
evaluateVariable = (name, env, mem, kont) ->
|
||||
kont mem, (env name), mem
|
||||
|
||||
# Page 130
|
||||
evaluateSet = (name, exp, env, mem, kont) ->
|
||||
evaluate exp, env, mem, (value, newmem) ->
|
||||
kont value, (update newmem, (env name), value)
|
||||
|
||||
# Page 131
|
||||
# TODO: I don't know that I trust this.
|
||||
evaluateApplication = (exp, exprs, env, mem, kont) ->
|
||||
|
||||
evaluateArguments = (exprs, env, mem, kont) ->
|
||||
if (pairp exprs)
|
||||
evaluate (car exprs), env, mem, (value, mem2) ->
|
||||
evaluateArguments (cdr exprs), env, mem2, (value2, mems3) ->
|
||||
kont (cons value, value2), mems3
|
||||
else
|
||||
kont cons(), mem
|
||||
|
||||
evaluate exp, env, mem, (fun, mems) ->
|
||||
evaluateArguments exprs, env, mems, (value2, mem3) ->
|
||||
if eq (fun sType), sFunction
|
||||
(fun sBehavior) value2, mem3, kont
|
||||
else
|
||||
throw new LispInterpreterError "Not a function #{(car value2)}"
|
||||
|
||||
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
|
||||
|
||||
allocate = (num, mem, q) ->
|
||||
if (num > 0)
|
||||
do ->
|
||||
addr = newLocation s
|
||||
allocate (num - 1), (expandStore addr, mem), (addrs, mem2) ->
|
||||
q (cons addr, addrs), mem2
|
||||
else
|
||||
q cons(), mem
|
||||
|
||||
expandStore = (highLocation, mem) ->
|
||||
update mem, 0, highLocation
|
||||
|
||||
newLocation = (mem) ->
|
||||
(mem 0) + 1
|
||||
|
||||
|
||||
|
||||
# Page 128
|
||||
evaluateIf = (expc, expt, expf, env, mem, kont) ->
|
||||
evaluate expc, env, mem, (env, mems) ->
|
||||
evaluate ((env "boolify") expt, expf), env, mems, kont
|
||||
|
||||
# Page 129
|
||||
# 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
|
||||
|
||||
|
||||
prox =
|
||||
"quote": (body, env, mem, kont, ix) -> evaluateQuote (cadr body), env, mem, kont
|
||||
"if": (body, env, mem, kont, ix) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont
|
||||
"begin": (body, env, mem, kont, ix) -> evaluateBegin (cdr body), env, mem, kont
|
||||
"set!": (body, env, mem, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, mem, kont
|
||||
"lambda": (body, env, mem, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, mem, kont
|
||||
|
||||
makeEvaluator = (ix = straight_evaluation) ->
|
||||
(exp, env, mem, kont) ->
|
||||
if ix.atomp exp
|
||||
if ix.symbolp exp
|
||||
evaluateVariable exp, env, mem, kont
|
||||
else
|
||||
evaluateQuote exp, env, mem, kont
|
||||
else
|
||||
body = ix.nvalu exp
|
||||
head = car body
|
||||
if prox[(ix.nvalu head)]?
|
||||
prox[(ix.nvalue head)](body, env, mem, kont, ix)
|
||||
else
|
||||
evaluateApplication body, (cadr body), env, mem, kont
|
||||
|
|
@ -0,0 +1,255 @@
|
|||
// Generated by CoffeeScript 1.9.1
|
||||
(function() {
|
||||
var LispInterpreterError, Node, Symbol, astSymbolsToLispSymbols, caadr, caar, cadar, cadddr, caddr, cadr, car, cdar, cddr, cdr, cons, env_init, eq, evaluateApplication, evaluateBegin, evaluateIf, evaluateLambda, evaluateSet, evaluateVariable, listToString, listToVector, makeEvaluator, metacadr, metadata_evaluation, nil, nilp, normalizeForm, normalizeForms, pairp, prox, ref, ref1, ref2, sBehavior, sFunction, sType, setcar, setcdr, straight_evaluation, the_false_value, update, updates,
|
||||
extend = function(child, parent) { for (var key in parent) { if (hasProp.call(parent, key)) child[key] = parent[key]; } function ctor() { this.constructor = child; } ctor.prototype = parent.prototype; child.prototype = new ctor(); child.__super__ = parent.prototype; return child; },
|
||||
hasProp = {}.hasOwnProperty;
|
||||
|
||||
ref = require("cons-lists/lists"), listToString = ref.listToString, listToVector = ref.listToVector, pairp = ref.pairp, cons = ref.cons, car = ref.car, cdr = ref.cdr, caar = ref.caar, cddr = ref.cddr, cdar = ref.cdar, cadr = ref.cadr, caadr = ref.caadr, cadar = ref.cadar, caddr = ref.caddr, nilp = ref.nilp, nil = ref.nil, setcdr = ref.setcdr, metacadr = ref.metacadr, setcar = ref.setcar;
|
||||
|
||||
ref1 = require("../chapter1/astToList"), normalizeForms = ref1.normalizeForms, normalizeForm = ref1.normalizeForm;
|
||||
|
||||
ref2 = require('../chapter1/reader_types'), Node = ref2.Node, Symbol = ref2.Symbol;
|
||||
|
||||
LispInterpreterError = (function(superClass) {
|
||||
extend(LispInterpreterError, superClass);
|
||||
|
||||
LispInterpreterError.prototype.name = 'LispInterpreterError';
|
||||
|
||||
function LispInterpreterError(message) {
|
||||
this.message = message;
|
||||
}
|
||||
|
||||
return LispInterpreterError;
|
||||
|
||||
})(Error);
|
||||
|
||||
the_false_value = cons("false", "boolean");
|
||||
|
||||
eq = function(id1, id2) {
|
||||
if (id1 instanceof Symbol && id2 instanceof Symbol) {
|
||||
return id1.name === id2.name;
|
||||
}
|
||||
return id1 === id2;
|
||||
};
|
||||
|
||||
astSymbolsToLispSymbols = function(node) {
|
||||
var handler;
|
||||
if (nilp(node)) {
|
||||
return nil;
|
||||
}
|
||||
if (!node.type === 'list') {
|
||||
throw new LispInterpreterError("Not a list of variable names");
|
||||
}
|
||||
handler = function(cell) {
|
||||
if (nilp(cell)) {
|
||||
return nil;
|
||||
}
|
||||
return cons((car(cell)).value, handler(cdr(cell)));
|
||||
};
|
||||
return handler(node.value);
|
||||
};
|
||||
|
||||
cadddr = metacadr('cadddr');
|
||||
|
||||
metadata_evaluation = {
|
||||
listp: function(node) {
|
||||
return node.type === 'list';
|
||||
},
|
||||
symbolp: function(node) {
|
||||
return node.type === 'symbol';
|
||||
},
|
||||
numberp: function(node) {
|
||||
return node.type === 'number';
|
||||
},
|
||||
stringp: function(node) {
|
||||
return node.type === 'string';
|
||||
},
|
||||
commentp: function(node) {
|
||||
return node.type === 'comment';
|
||||
},
|
||||
nvalu: function(node) {
|
||||
return node.value;
|
||||
},
|
||||
mksymbols: function(list) {
|
||||
return astSymbolsToLispSymbols(list);
|
||||
}
|
||||
};
|
||||
|
||||
straight_evaluation = {
|
||||
listp: function(cell) {
|
||||
return cell.__type === 'list';
|
||||
},
|
||||
symbolp: function(cell) {
|
||||
var ref3;
|
||||
return typeof cell === 'string' && cell.length > 0 && ((ref3 = cell[0]) !== "\"" && ref3 !== ";");
|
||||
},
|
||||
commentp: function(cell) {
|
||||
return typeof cell === 'string' && cell.length > 0 && cell[0] === ";";
|
||||
},
|
||||
numberp: function(cell) {
|
||||
return typeof cell === 'number';
|
||||
},
|
||||
stringp: function(cell) {
|
||||
return typeof cell === 'string' && cell.length > 0 && cell[0] === "\"";
|
||||
},
|
||||
boolp: function(cell) {
|
||||
return typeof cell === 'boolean';
|
||||
},
|
||||
nullp: function(cell) {
|
||||
return cell === null;
|
||||
},
|
||||
vectorp: function(cell) {
|
||||
return (!straight_evaluation.listp(cell)) && toString.call(cell) === '[object Array]';
|
||||
},
|
||||
recordp: function(cell) {
|
||||
return (cell._prototype == null) && toSTring.call(cell) === '[object Object]';
|
||||
},
|
||||
objectp: function(cell) {
|
||||
return (cell._prototype != null) && toString.call(cell) === '[object Object]';
|
||||
},
|
||||
nilp: function(cell) {
|
||||
return nilp(cell);
|
||||
},
|
||||
nvalu: function(cell) {
|
||||
return cell;
|
||||
},
|
||||
mksymbols: function(cell) {
|
||||
return cell;
|
||||
}
|
||||
};
|
||||
|
||||
sType = new Symbol('type');
|
||||
|
||||
sBehavior = new Symbol('behavior');
|
||||
|
||||
sFunction = new Symbol('function');
|
||||
|
||||
env_init = function(id) {
|
||||
throw LispInterpreterError("No binding for " + id);
|
||||
};
|
||||
|
||||
update = function(mem, addr, value) {
|
||||
return function(addra) {
|
||||
if (addra === addr) {
|
||||
return value;
|
||||
} else {
|
||||
return mem(addra);
|
||||
}
|
||||
};
|
||||
};
|
||||
|
||||
updates = function(mem, addrs, values) {
|
||||
if (pairp(addrs)) {
|
||||
return updates(update(mem, car(addrs), car(values)), cdr(addrs), cdr(values));
|
||||
} else {
|
||||
return mem;
|
||||
}
|
||||
};
|
||||
|
||||
evaluateVariable = function(name, env, mem, kont) {
|
||||
return kont(mem, env(name), mem);
|
||||
};
|
||||
|
||||
evaluateSet = function(name, exp, env, mem, kont) {
|
||||
return evaluate(exp, env, mem, function(value, newmem) {
|
||||
return kont(value, update(newmem, env(name), value));
|
||||
});
|
||||
};
|
||||
|
||||
evaluateApplication = function(exp, exprs, env, mem, kont) {
|
||||
var evaluateArguments;
|
||||
evaluateArguments = function(exprs, env, mem, kont) {
|
||||
if (pairp(exprs)) {
|
||||
return evaluate(car(exprs), env, mem, function(value, mem2) {
|
||||
return evaluateArguments(cdr(exprs), env, mem2, function(value2, mems3) {
|
||||
return kont(cons(value, value2), mems3);
|
||||
});
|
||||
});
|
||||
} else {
|
||||
return kont(cons(), mem);
|
||||
}
|
||||
};
|
||||
return evaluate(exp, env, mem, function(fun, mems) {
|
||||
return evaluateArguments(exprs, env, mems, function(value2, mem3) {
|
||||
if (eq(fun(sType), sFunction)) {
|
||||
return (fun(sBehavior))(value2, mem3, kont);
|
||||
} else {
|
||||
throw new LispInterpreterError("Not a function " + (car(value2)));
|
||||
}
|
||||
});
|
||||
});
|
||||
};
|
||||
|
||||
evaluateLambda = function(names, exprs, env, mem, kont) {
|
||||
return allocate(1, mem, function(addrs, mem2) {
|
||||
return kont(createFunction(car(addrs), function(values, mem, kont) {
|
||||
if (eq(length(names), length(values))) {
|
||||
return allocate(length(names), mem, function(addrs, mem2) {
|
||||
return evaluateBegin(exprs, updates(env, names, addrs), updates(mem2, addrs, values), kont);
|
||||
});
|
||||
} else {
|
||||
throw new LispInterpreterError("Incorrect Arrity");
|
||||
}
|
||||
}), mem2);
|
||||
});
|
||||
};
|
||||
|
||||
evaluateIf = function(expc, expt, expf, env, mem, kont) {
|
||||
return evaluate(expc, env, mem, function(env, mems) {
|
||||
return evaluate((env("boolify"))(expt, expf), env, mems, kont);
|
||||
});
|
||||
};
|
||||
|
||||
evaluateBegin = function(exps, env, mem, kont) {
|
||||
if (pairp(cdr(exps))) {
|
||||
return evaluate(car(exps), env, mem, function(_, mems) {
|
||||
return evaluateBegin(cdr(exps), env, mems, kont);
|
||||
});
|
||||
} else {
|
||||
return evaluate(car(exps), env, mem, kont);
|
||||
}
|
||||
};
|
||||
|
||||
prox = {
|
||||
"quote": function(body, env, mem, kont, ix) {
|
||||
return evaluateQuote(cadr(body), env, mem, kont);
|
||||
},
|
||||
"if": function(body, env, mem, kont, ix) {
|
||||
return evaluateIf(cadr(body), caddr(body), cadddr(body), env, mem, kont);
|
||||
},
|
||||
"begin": function(body, env, mem, kont, ix) {
|
||||
return evaluateBegin(cdr(body), env, mem, kont);
|
||||
},
|
||||
"set!": function(body, env, mem, kont, ix) {
|
||||
return evaluateSet(ix.nvalu(cadr(body)), caddr(body), env, mem, kont);
|
||||
},
|
||||
"lambda": function(body, env, mem, kont, ix) {
|
||||
return evaluateLambda(ix.mksymbols(cadr(body)), cddr(body), env, mem, kont);
|
||||
}
|
||||
};
|
||||
|
||||
makeEvaluator = function(ix) {
|
||||
if (ix == null) {
|
||||
ix = straight_evaluation;
|
||||
}
|
||||
return function(exp, env, mem, kont) {
|
||||
var body, head;
|
||||
if (ix.atomp(exp)) {
|
||||
if (ix.symbolp(exp)) {
|
||||
return evaluateVariable(exp, env, mem, kont);
|
||||
} else {
|
||||
return evaluateQuote(exp, env, mem, kont);
|
||||
}
|
||||
} else {
|
||||
body = ix.nvalu(exp);
|
||||
head = car(body);
|
||||
if (prox[ix.nvalu(head)] != null) {
|
||||
return prox[ix.nvalue(head)](body, env, mem, kont, ix);
|
||||
} else {
|
||||
return evaluateApplication(body, cadr(body), env, mem, kont);
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
|
||||
}).call(this);
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
|
||||
{inspect} = require "util"
|
||||
{Node, Comment, Symbol} = require "../chapter1/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 -> Node => Error)
|
||||
handleError = (message) ->
|
||||
(line, column) -> new Node('error', message, line, column)
|
||||
|
||||
# IO -> Node => Comment
|
||||
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 -> (Node => Literal => String) | 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) -> (Node => Literal => 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 'symbol', (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", 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 -> Form
|
||||
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 -> (Form* | Error)
|
||||
readForms = (inStream) ->
|
||||
inStream = if inStream instanceof Source then inStream else new Source inStream
|
||||
return nil if inStream.done()
|
||||
|
||||
# IO -> (FORM*, IO) | 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
|
||||
Loading…
Reference in New Issue