228 lines
7.0 KiB
CoffeeScript
228 lines
7.0 KiB
CoffeeScript
{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
|
|
print = require "../chapter1/print"
|
|
|
|
cadddr = metacadr('cadddr')
|
|
|
|
{inspect} = require "util"
|
|
|
|
cpsdecorate = (fn) ->
|
|
(args...) ->
|
|
callback = args[args.length - 1]
|
|
tocall = args[0 ... (args.length-1)]
|
|
callback fn.apply(@, args)
|
|
|
|
ntype = (node) -> car node
|
|
nvalu = (node) -> cadr node
|
|
|
|
[listToString, listToVector, pairp, cons, car, cdr,
|
|
caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp,
|
|
nil, setcdr, metacadr, ntype, nvalu] = [listToString,
|
|
listToVector, pairp, cons, car, cdr, caar, cddr,
|
|
cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr,
|
|
metacadr, ntype, nvalu].map(cpsdecorate)
|
|
|
|
# Debugging tool.
|
|
|
|
env_init = nil
|
|
env_global = env_init
|
|
|
|
# Takes a name and a value and pushes those onto the global environment.
|
|
|
|
definitial = (name, value = nil, callback) ->
|
|
cons name, value, (ls) ->
|
|
cons ls, env_global, callback
|
|
|
|
# Takes a name, a native function, and the expected arity of that
|
|
# function, and returns the global environment with new a (native)
|
|
# function perpared to unpack any (interpreter) variable pairs and
|
|
# apply the (native) function with them.
|
|
|
|
defprimitive = (name, nativ, arity) ->
|
|
definitial name, ((args) ->
|
|
vmargs = listToVector(args)
|
|
if (vmargs.length == arity)
|
|
nativ.apply null, vmargs
|
|
else
|
|
throw "Incorrect arity")
|
|
|
|
the_false_value = (cons "false", "boolean")
|
|
|
|
definitial "#t", true
|
|
definitial "#f", the_false_value
|
|
definitial "nil", nil
|
|
definitial "foo"
|
|
definitial "bar"
|
|
definitial "fib"
|
|
definitial "fact"
|
|
|
|
# Wraps a native predicate in function to ensure the interpreter's
|
|
# notion of falsity is preserved.
|
|
|
|
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
|
|
defprimitive "log", ((a) -> console.log a), 1
|
|
defprimitive "+", ((a, b) -> a + b), 2
|
|
defprimitive "*", ((a, b) -> a * b), 2
|
|
defprimitive "-", ((a, b) -> a - b), 2
|
|
defprimitive "/", ((a, b) -> a / b), 2
|
|
defpredicate "lt", ((a, b) -> a < b), 2
|
|
defpredicate "eq?", ((a, b) -> a == b), 2
|
|
|
|
# Takes an environment, a list of names and a list of values, and for
|
|
# each name and value pair pushes that pair onto the list, adding them
|
|
# to the environment.
|
|
|
|
extend = (env, variables, values) ->
|
|
if (pairp variables)
|
|
if (pairp values)
|
|
(cons (cons (car variables), (car values)),
|
|
(extend env, (cdr variables), (cdr values)))
|
|
else
|
|
throw "Too few values"
|
|
else if (nilp variables)
|
|
if (nilp values) then env else throw "Too many values"
|
|
else
|
|
if (symbolp variables)
|
|
(cons (cons variables, values), env)
|
|
else
|
|
nil
|
|
|
|
# Takes a list of variable names, a function body, and an environment
|
|
# at the time of evaluation, and returns:
|
|
# a (native) function that takes a list of values, applies them to the
|
|
# environment, and evaluates the body, returning the resulting value.
|
|
|
|
make_function = (variables, body, env) ->
|
|
(values) -> eprogn body, (extend env, variables, values)
|
|
|
|
# Evaluates a (native) function with of one arg with the arg provided.
|
|
# Invoke runs the functions created by make_function, and is unrelated
|
|
# to the native functions of defprimitive()
|
|
|
|
invoke = (fn, arg) -> (fn arg)
|
|
|
|
# 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 macro
|
|
# often named "->"
|
|
|
|
eprogn = (exps, env, callback) ->
|
|
if (pairp exps)
|
|
if pairp (cdr exps)
|
|
evaluate (car exps), env, (c) ->
|
|
eprogn (cdr exps), env, callback
|
|
else
|
|
evaluate (car exps), env, callback
|
|
else
|
|
nil
|
|
|
|
# Evaluates a list of expressions and returns a list of resolved
|
|
# values.
|
|
|
|
evlis = (exps, env, callback) ->
|
|
callback if (pairp exps)
|
|
if (pairp cdr exps)
|
|
evaluate (cons (evaluate (car exps), env), (evlis (cdr exps), env))
|
|
else
|
|
nil
|
|
|
|
# Locates a named reference in the environment and returns its value.
|
|
|
|
lookup = (id, env, callback) ->
|
|
callback if (pairp env)
|
|
if (caar env) == id
|
|
cdar env
|
|
else
|
|
lookup id, (cdr env)
|
|
else
|
|
nil
|
|
|
|
# Locates a named reference in the environment and replaces its value
|
|
# with a new value.
|
|
|
|
update = (id, env, value, callback ) ->
|
|
callback 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.
|
|
|
|
# Yeah, for the CPS edition, this is WAY cheating:
|
|
|
|
astSymbolsToLispSymbols = (node, callback) ->
|
|
return nil if nilp node
|
|
throw "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)
|
|
callback handler(nvalu node)
|
|
|
|
|
|
# Takes an AST node and evaluates it and its contents, returning the
|
|
# final value of the calculation. A node may be ("list" (... contents
|
|
# ...)) or ("number" 42) or ("symbol" x), etc.
|
|
|
|
|
|
ceq = (l, r, thencallback, elsecallback) ->
|
|
(if l is r then thencallback else elsecallback)()
|
|
|
|
cin = (l, r, thencallback, elsecallback) ->
|
|
(if l in r then thencallback else elsecallback)()
|
|
|
|
cswitch = (key, ops, callback) ->
|
|
return ops[key](callback) if key of ops
|
|
return ops['_default'](callback) if '_default' of ops
|
|
throw new Error("Can't handle invocation of #{key}")
|
|
|
|
cpsevaluate = (exp, env, callback) ->
|
|
cdr exp, (envexp) ->
|
|
evlis envexp, env, (newenv) ->
|
|
car exp, (fnhandle) ->
|
|
evaluate fnhandle, env, callback
|
|
|
|
syntax =
|
|
"quote": (callback) -> cdr exp, callback
|
|
"if": (callback) ->
|
|
cadr exp, (e) ->
|
|
evaluate e, env, (c) ->
|
|
cif(c, the_false_value,
|
|
(-> cadddr exp, (e) -> evaluate e, env, callback),
|
|
(-> caddr exp, (e) -> evaluate e, env, callback))
|
|
"begin": (callback) -> cdr exp, ((e) -> eprogn e, env, callback)
|
|
"set!": (callback) -> cadr exp, (e) ->
|
|
nvalu e, (n) ->
|
|
caddr exp, (r) ->
|
|
evaluate r, env, (r2) ->
|
|
update n, env, r2, callback
|
|
"lambda": (callback) -> cddr expr, (body) ->
|
|
cadr exp, (astSymbols) ->
|
|
astSymbolsToLispSymbols astSymbols, (lispSymbols) ->
|
|
make_function lispSymbols, body, env, callback
|
|
"_default": (callback) -> cpsevaluate exp, env, callback
|
|
|
|
evaluate = (e, env, callback) ->
|
|
ntype e, (type) ->
|
|
nvalu e, (exp) ->
|
|
ceq type, "symbol", (-> lookup exp, env, callback), ->
|
|
cin type, ["number", "string", "boolean", "vector"], (-> callback exp), (->
|
|
ceq type, "list", (->
|
|
car exp, (head) ->
|
|
ntype head, (h) -> ceq h, "symbol", -> nvalu head, (hv) ->
|
|
cswitch hv, syntax, callback
|
|
), -> cpsevaluate exp, env, callback
|
|
), -> throw new Error("Can't handle a #{type}")
|
|
|
|
module.exports = (c) -> evaluate c, env_global
|
|
|