[refactor] Custom reader types have unique Javascript equivalents now.
This commit is contained in:
parent
bb0c06b073
commit
5bba101ee2
|
|
@ -1,6 +1,7 @@
|
|||
{car, cdr, cons, listp, nilp, nil,
|
||||
list, pairp, listToString} = require 'cons-lists/lists'
|
||||
{aSymbol, aValue, astObject} = require './astAccessors'
|
||||
{Symbol} = require './reader_types'
|
||||
|
||||
# RICH_AST -> LISP_AST
|
||||
|
||||
|
|
@ -25,7 +26,7 @@ normalizeForm = (form) ->
|
|||
'record': (atom) -> listToRecord1(atom)
|
||||
|
||||
# Basic native types. Meh.
|
||||
'symbol': id
|
||||
'symbol': (a) -> a.v
|
||||
'number': id
|
||||
'string': (atom) -> atom
|
||||
'nil': (atom) -> nil
|
||||
|
|
|
|||
|
|
@ -7,11 +7,13 @@ class LispInterpreterError extends Error
|
|||
name: 'LispInterpreterError'
|
||||
constructor: (@message) ->
|
||||
|
||||
|
||||
env_init = nil
|
||||
env_global = env_init
|
||||
|
||||
ntype = (node) -> car node
|
||||
nvalu = (node) -> cadr node
|
||||
defpredicate = (name, nativ, arity) ->
|
||||
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
|
||||
|
||||
|
||||
definitial = (name, value = nil) ->
|
||||
env_global = (cons (cons name, value), env_global)
|
||||
|
|
@ -25,8 +27,6 @@ defprimitive = (name, nativ, arity) ->
|
|||
else
|
||||
throw (new LispInterpreterError "Incorrect arity"))
|
||||
|
||||
the_false_value = (cons "false", "boolean")
|
||||
|
||||
definitial "#t", true
|
||||
definitial "#f", the_false_value
|
||||
definitial "nil", nil
|
||||
|
|
@ -35,9 +35,6 @@ definitial "bar"
|
|||
definitial "fib"
|
||||
definitial "fact"
|
||||
|
||||
defpredicate = (name, nativ, arity) ->
|
||||
defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
|
||||
|
||||
defprimitive "cons", cons, 2
|
||||
defprimitive "car", car, 2
|
||||
defprimitive "set-cdr!", setcdr, 2
|
||||
|
|
@ -48,108 +45,131 @@ defprimitive "/", ((a, b) -> a / b), 2
|
|||
defpredicate "lt", ((a, b) -> a < b), 2
|
||||
defpredicate "eq?", ((a, b) -> a == b), 2
|
||||
|
||||
extend = (env, variables, values) ->
|
||||
if (pairp variables)
|
||||
if (pairp values)
|
||||
(cons (cons (car variables), (car values)),
|
||||
(extend env, (cdr variables), (cdr values)))
|
||||
else
|
||||
throw new LispInterpreterError "Too few values"
|
||||
else if (nilp variables)
|
||||
if (nilp values) then env else throw new LispInterpreterError "Too many values"
|
||||
else
|
||||
if (symbolp variables)
|
||||
(cons (cons variables, values), env)
|
||||
else
|
||||
nil
|
||||
|
||||
make_function = (variables, body, env) ->
|
||||
(values) -> eprogn body, (extend env, variables, values)
|
||||
|
||||
invoke = (fn, args) ->
|
||||
(fn args)
|
||||
|
||||
# Takes a list of nodes and calls evaluate on each one, returning the
|
||||
# last one as the value of the total expression. In this example, we
|
||||
# are hard-coding what ought to be a macro, namely the threading
|
||||
# macros, "->"
|
||||
|
||||
eprogn = (exps, env) ->
|
||||
if (pairp exps)
|
||||
if pairp (cdr exps)
|
||||
evaluate (car exps), env
|
||||
eprogn (cdr exps), env
|
||||
else
|
||||
evaluate (car exps), env
|
||||
else
|
||||
nil
|
||||
|
||||
evlis = (exps, env) ->
|
||||
if (pairp exps)
|
||||
(cons (evaluate (car exps), env), (evlis (cdr exps), env))
|
||||
else
|
||||
nil
|
||||
|
||||
lookup = (id, env) ->
|
||||
if (pairp env)
|
||||
if (caar env) == id
|
||||
cdar env
|
||||
else
|
||||
lookup id, (cdr env)
|
||||
else
|
||||
nil
|
||||
|
||||
update = (id, env, value) ->
|
||||
if (pairp env)
|
||||
if (caar env) == id
|
||||
setcdr value, (car env)
|
||||
value
|
||||
else
|
||||
update id, (cdr env), value
|
||||
else
|
||||
nil
|
||||
|
||||
# This really ought to be the only place where the AST meets the
|
||||
# interpreter core. I can't help but think that this design precludes
|
||||
# pluggable interpreter core.
|
||||
|
||||
astSymbolsToLispSymbols = (node) ->
|
||||
return nil if nilp node
|
||||
throw (new LispInterpreterError "Not a list of variable names") if not (ntype(node) is 'list')
|
||||
handler = (node) ->
|
||||
return nil if nilp node
|
||||
cons (nvalu car node), (handler cdr node)
|
||||
handler(nvalu node)
|
||||
|
||||
|
||||
# Takes an AST node and evaluates it and its contents. A node may be
|
||||
# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
|
||||
the_false_value = (cons "false", "boolean")
|
||||
|
||||
cadddr = metacadr('cadddr')
|
||||
|
||||
evaluate = (e, env) ->
|
||||
[type, exp] = [(ntype e), (nvalu e)]
|
||||
if type == "symbol"
|
||||
return lookup exp, env
|
||||
else if type in ["number", "string", "boolean", "vector"]
|
||||
return exp
|
||||
else if type == "list"
|
||||
head = car exp
|
||||
if (ntype head) == 'symbol'
|
||||
switch (nvalu head)
|
||||
when "quote" then cdr exp
|
||||
when "if"
|
||||
unless (evaluate (cadr exp), env) == the_false_value
|
||||
evaluate (caddr exp), env
|
||||
else
|
||||
evaluate (cadddr exp), env
|
||||
when "begin" then eprogn (cdr exp), env
|
||||
when "set!" then update (nvalu cadr exp), env, (evaluate (caddr exp), env)
|
||||
when "lambda" then make_function (astSymbolsToLispSymbols cadr exp), (cddr exp), env
|
||||
else invoke (evaluate (car exp), env), (evlis (cdr exp), env)
|
||||
else
|
||||
invoke (evaluate (car exp), env), (evlis (cdr exp), env)
|
||||
else
|
||||
throw new LispInterpreterError "Can't handle a #{type}"
|
||||
metadata_evaluation =
|
||||
listp: (node) -> (car node) == 'list'
|
||||
symbolp: (node) -> (car node) == 'symbol'
|
||||
numberp: (node) -> (car node) == 'number'
|
||||
stringp: (node) -> (car node) == 'string'
|
||||
nvalu: (node) -> cadr node
|
||||
|
||||
straight_evaluation =
|
||||
listp: (node) -> node.__type == 'list'
|
||||
symbolp: (node) -> node instanceOf Symbol
|
||||
commentp: (node) -> node instanceOf Comment
|
||||
numberp: (node) -> typeof node == 'number'
|
||||
stringp: (node) -> typeof node == 'string'
|
||||
boolp: (node) -> typeof node == 'boolean'
|
||||
nullp: (node) -> node == null
|
||||
vectorp: (node) -> (not listp node) and toString.call(node) == '[object Array]'
|
||||
recordp: (node) -> (not x._prototype?) and toSTring.call(node) == '[object Object]')
|
||||
objectp: (node) -> (x._prototype?) and toString.call(node) == '[object Object]')
|
||||
nilp: (node) -> node == nilp
|
||||
nvalu: (node) -> node
|
||||
|
||||
makeEvaluator = (ix = straight_evaluation) ->
|
||||
(exp, env) ->
|
||||
extend = (env, variables, values) ->
|
||||
if (pairp variables)
|
||||
if (pairp values)
|
||||
(cons (cons (car variables), (car values)),
|
||||
(extend env, (cdr variables), (cdr values)))
|
||||
else
|
||||
throw new LispInterpreterError "Too few values"
|
||||
else if (nilp variables)
|
||||
if (nilp values) then env else throw new LispInterpreterError "Too many values"
|
||||
else
|
||||
if (symbolp variables)
|
||||
(cons (cons variables, values), env)
|
||||
else
|
||||
nil
|
||||
|
||||
make_function = (variables, body, env) ->
|
||||
(values) -> eprogn body, (extend env, variables, values)
|
||||
|
||||
invoke = (fn, args) ->
|
||||
(fn args)
|
||||
|
||||
# Takes a list of nodes and calls evaluate on each one, returning the
|
||||
# last one as the value of the total expression. In this example, we
|
||||
# are hard-coding what ought to be a macro, namely the threading
|
||||
# macros, "->"
|
||||
|
||||
eprogn = (exps, env) ->
|
||||
if (pairp exps)
|
||||
if pairp (cdr exps)
|
||||
evaluate (car exps), env
|
||||
eprogn (cdr exps), env
|
||||
else
|
||||
evaluate (car exps), env
|
||||
else
|
||||
nil
|
||||
|
||||
evlis = (exps, env) ->
|
||||
if (pairp exps)
|
||||
(cons (evaluate (car exps), env), (evlis (cdr exps), env))
|
||||
else
|
||||
nil
|
||||
|
||||
lookup = (id, env) ->
|
||||
if (pairp env)
|
||||
if (caar env) == id
|
||||
cdar env
|
||||
else
|
||||
lookup id, (cdr env)
|
||||
else
|
||||
nil
|
||||
|
||||
update = (id, env, value) ->
|
||||
if (pairp env)
|
||||
if (caar env) == id
|
||||
setcdr value, (car env)
|
||||
value
|
||||
else
|
||||
update id, (cdr env), value
|
||||
else
|
||||
nil
|
||||
|
||||
# This really ought to be the only place where the AST meets the
|
||||
# interpreter core. I can't help but think that this design precludes
|
||||
# pluggable interpreter core.
|
||||
|
||||
astSymbolsToLispSymbols = (node) ->
|
||||
return nil if nilp node
|
||||
throw (new LispInterpreterError "Not a list of variable names") if not (ntype(node) is 'list')
|
||||
handler = (node) ->
|
||||
return nil if nilp node
|
||||
cons (nvalu car node), (handler cdr node)
|
||||
handler(nvalu node)
|
||||
|
||||
# Takes an AST node and evaluates it and its contents. A node may be
|
||||
# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
|
||||
|
||||
[type, exp] = [(ntype e), (nvalu e)]
|
||||
if type == "symbol"
|
||||
return lookup exp, env
|
||||
else if type in ["number", "string", "boolean", "vector"]
|
||||
return exp
|
||||
else if type == "list"
|
||||
head = car exp
|
||||
if (ntype head) == 'symbol'
|
||||
switch (nvalu head)
|
||||
when "quote" then cdr exp
|
||||
when "if"
|
||||
unless (evaluate (cadr exp), env) == the_false_value
|
||||
evaluate (caddr exp), env
|
||||
else
|
||||
evaluate (cadddr exp), env
|
||||
when "begin" then eprogn (cdr exp), env
|
||||
when "set!" then update (nvalu cadr exp), env, (evaluate (caddr exp), env)
|
||||
when "lambda" then make_function (astSymbolsToLispSymbols cadr exp), (cddr exp), env
|
||||
else invoke (evaluate (car exp), env), (evlis (cdr exp), env)
|
||||
else
|
||||
invoke (evaluate (car exp), env), (evlis (cdr exp), env)
|
||||
else
|
||||
throw new LispInterpreterError "Can't handle a #{type}"
|
||||
|
||||
module.exports = (c) -> evaluate c, env_global
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
|
||||
{inspect} = require "util"
|
||||
{Symbol, Comment} = require "./reader_types"
|
||||
|
||||
|
||||
NEWLINES = ["\n", "\r", "\x0B", "\x0C"]
|
||||
|
|
@ -28,17 +29,19 @@ class Source
|
|||
|
||||
done: -> @index > @max
|
||||
|
||||
mkNode = (obj) -> Object.defineProperty obj, '__node', {value: true}
|
||||
|
||||
# IO -> IO
|
||||
skipWS = (inStream) ->
|
||||
while inStream.peek() in WHITESPACE then inStream.next()
|
||||
|
||||
# (type, value, line, column) -> (node {type, value, line, column)}
|
||||
makeObj = (type, value, line, column) ->
|
||||
list(type, value, line, column)
|
||||
mkObj = (type, value, line, column) ->
|
||||
mkNode list type, value, line, column
|
||||
|
||||
# msg -> (IO -> Node => Error)
|
||||
handleError = (message) ->
|
||||
(line, column) -> makeObj('error', message, line, column)
|
||||
(line, column) -> mkObj('error', message, line, column)
|
||||
|
||||
# IO -> Node => Comment
|
||||
readComment = (inStream) ->
|
||||
|
|
@ -47,7 +50,7 @@ readComment = (inStream) ->
|
|||
inStream.next()).join("")
|
||||
if not inStream.done()
|
||||
inStream.next()
|
||||
makeObj 'comment', r, line, column
|
||||
mkObj 'comment', (new Comment r), line, column
|
||||
|
||||
# IO -> (Node => Literal => String) | Error
|
||||
readString = (inStream) ->
|
||||
|
|
@ -60,7 +63,7 @@ readString = (inStream) ->
|
|||
if inStream.done()
|
||||
return handleError("end of file seen before end of string.")(line, column)
|
||||
inStream.next()
|
||||
makeObj 'string', (string.join ''), line, column
|
||||
mkObj 'string', (string.join ''), line, column
|
||||
|
||||
# (String) -> (Node => Literal => Number) | Nothing
|
||||
readMaybeNumber = (symbol) ->
|
||||
|
|
@ -86,8 +89,8 @@ readSymbol = (inStream, tableKeys) ->
|
|||
inStream.next()).join ''
|
||||
number = readMaybeNumber symbol
|
||||
if number?
|
||||
return makeObj 'number', number, line, column
|
||||
makeObj 'symbol', symbol, line, column
|
||||
return mkObj 'number', number, line, column
|
||||
mkObj 'symbol', (new Symbol symbol), line, column
|
||||
|
||||
|
||||
# (Delim, TypeName) -> IO -> (IO, node) | Error
|
||||
|
|
@ -99,7 +102,7 @@ makeReadPair = (delim, type) ->
|
|||
[line, column] = inStream.position()
|
||||
if inStream.peek() == delim
|
||||
inStream.next()
|
||||
return makeObj(type, nil, line, column)
|
||||
return mkObj(type, nil, line, column)
|
||||
|
||||
# IO -> (IO, Node) | Error
|
||||
dotted = false
|
||||
|
|
@ -112,12 +115,12 @@ makeReadPair = (delim, type) ->
|
|||
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 (car obj) == 'error'
|
||||
if (car obj) == 'symbol' and (car cdr obj) == '.'
|
||||
if (car obj) == 'symbol' and (car cdr obj).v == '.'
|
||||
dotted = true
|
||||
return readEachPair inStream
|
||||
cons obj, readEachPair inStream
|
||||
|
||||
ret = makeObj type, readEachPair(inStream), line, column
|
||||
ret = mkObj type, readEachPair(inStream), line, column
|
||||
inStream.next()
|
||||
ret
|
||||
|
||||
|
|
@ -130,7 +133,7 @@ prefixReader = (type) ->
|
|||
[line1, column1] = inStream.position()
|
||||
obj = read inStream, true, null, true
|
||||
return obj if (car obj) == 'error'
|
||||
makeObj "list", cons((makeObj("symbol", type, line1, column1)), cons(obj)), line, column
|
||||
mkObj "list", cons((mkObj("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
|
||||
|
|
@ -200,7 +203,7 @@ readForms = (inStream) ->
|
|||
cons obj, readEach inStream
|
||||
|
||||
obj = readEach inStream
|
||||
if (car obj) == 'error' then obj else makeObj "list", obj, line, column
|
||||
if (car obj) == 'error' then obj else mkObj "list", obj, line, column
|
||||
|
||||
exports.read = read
|
||||
exports.readForms = readForms
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
exports.Symbol = class
|
||||
constructor: (@v) ->
|
||||
|
||||
exports.Comment = class
|
||||
constructor: (@text) ->
|
||||
|
||||
|
|
@ -264,7 +264,6 @@ evaluateCatch = (tag, body, env, kont) ->
|
|||
class CatchCont extends Continuation
|
||||
constructor: (@kont, @body, @env) ->
|
||||
resume: (value) ->
|
||||
console.log(value)
|
||||
evaluateBegin @body, @env, (new LabeledCont @kont, normalizeForm car value)
|
||||
|
||||
class LabeledCont extends Continuation
|
||||
|
|
|
|||
Loading…
Reference in New Issue