Basic arithmetic works!
This commit is contained in:
parent
e0b6b44178
commit
356d4561b2
|
|
@ -3,12 +3,17 @@
|
|||
metacadr, setcar} = require "cons-lists/lists"
|
||||
{map} = require "cons-lists/reduce"
|
||||
{length} = require "cons-lists/reduce"
|
||||
{normalizeForms, normalizeForm} = require "../chapter1/astToList"
|
||||
{Node, Comment, Symbol} = require '../chapter1/reader_types'
|
||||
{Node, Comment, Symbol} = require '../chapter5/reader_types'
|
||||
{inspect} = require 'util'
|
||||
|
||||
itap = (a) -> return inspect a, true, null, false
|
||||
|
||||
class Value
|
||||
constructor: (@v) ->
|
||||
|
||||
inValue = (f) ->
|
||||
new Value(f)
|
||||
|
||||
class LispInterpreterError extends Error
|
||||
name: 'LispInterpreterError'
|
||||
constructor: (@message) ->
|
||||
|
|
@ -40,26 +45,61 @@ consp = (e) ->
|
|||
convert = (exp, store) ->
|
||||
conv = (e) ->
|
||||
if consp e
|
||||
cons (conv content.v, (store (car e))), (conv content.v, (store (cadr e)))
|
||||
cons (conv (store (car e)).v), (conv (store (cadr e)).v)
|
||||
else
|
||||
e
|
||||
conv (content.v e)
|
||||
conv exp.v
|
||||
|
||||
# 5.2.4
|
||||
# f[y → z] = λx . if y = x then z else f(x) endif
|
||||
#
|
||||
# Accepts a parent function, and ID and a value. Returns a function
|
||||
# that takes a request ID. If the request ID equals the ID above,
|
||||
# return the value, else call the parent function with the request
|
||||
# ID.
|
||||
#
|
||||
# Calls allocate
|
||||
|
||||
extend = (next, id, value) ->
|
||||
(x) -> if (eq x, id) then value else (next x)
|
||||
|
||||
# f[y* → z*] = if #y>0 then f[y*†1 → z*†1][y*↓1 → z*↓1] else f endif
|
||||
#
|
||||
# Helper. Builds a stack of extend() functions, at tail of which it
|
||||
# appends the parent function.
|
||||
#
|
||||
#
|
||||
lextends = (fn, ids, values) ->
|
||||
if (pairp pts)
|
||||
extend (@lextends fn, (cdr pts), (cdr ims)), (car pts), (car ims)
|
||||
else
|
||||
fn
|
||||
|
||||
|
||||
|
||||
translate = (exp, store, qont) ->
|
||||
if (pairp exp)
|
||||
translate (car exp), store, (val1, store1) ->
|
||||
translate (cdr exp), store1, (val2, store2) ->
|
||||
allocate store2, 2, (store, addrs) ->
|
||||
qont (inValue addrs), (extend (extend store, (car addrs), val1), (cadr addrs), val2)
|
||||
else
|
||||
qont (inValue exp), store
|
||||
|
||||
# Allocate is a function that takes a store, a number of addresses to
|
||||
# allocate within that store, and a continuation; at the end, it calls
|
||||
# the continuation with the store object and the new addresses.
|
||||
|
||||
allocate = (->
|
||||
loc = 0
|
||||
(store, num, qont) ->
|
||||
addrs = cons()
|
||||
n = num
|
||||
until n <= 0
|
||||
loc = loc + 1
|
||||
n = n - 1
|
||||
cons loc, addrs
|
||||
qont store, addrs)()
|
||||
aloop = (n, a) ->
|
||||
if (n > 0)
|
||||
loc = loc - 1
|
||||
aloop (n - 1), (cons loc, a)
|
||||
else
|
||||
qont store, a
|
||||
aloop(num, cons()))()
|
||||
|
||||
sBehavior = new Symbol 'behavior'
|
||||
sBoolean = new Symbol 'boolean'
|
||||
|
|
@ -67,11 +107,17 @@ sBoolify = new Symbol 'boolify'
|
|||
sFunction = new Symbol 'function'
|
||||
sSymbol = new Symbol 'symbol'
|
||||
sString = new Symbol 'string'
|
||||
sValue = new Symbol 'chars'
|
||||
sQuote = new Symbol 'quote'
|
||||
sLambda = new Symbol 'lambda'
|
||||
sIf = new Symbol 'if'
|
||||
sValue = new Symbol 'value'
|
||||
sChars = new Symbol 'chars'
|
||||
sBegin = new Symbol 'begin'
|
||||
sName = new Symbol 'name'
|
||||
sNumber = new Symbol 'number'
|
||||
sNull = new Symbol 'null'
|
||||
sTag = new Symbol 'tag'
|
||||
sSet = new Symbol 'set'
|
||||
sType = new Symbol 'type'
|
||||
sValue = new Symbol 'value'
|
||||
sPair = new Symbol 'pair'
|
||||
|
|
@ -80,24 +126,20 @@ sCdr = new Symbol 'cdr'
|
|||
sSetCar = new Symbol 'setcar'
|
||||
sSetCdr = new Symbol 'setcdr'
|
||||
|
||||
class Value
|
||||
constructor: (@content) ->
|
||||
|
||||
inValue = (f) ->
|
||||
new Value(f)
|
||||
|
||||
ValueToFunction = (e) ->
|
||||
c = e.content
|
||||
c = e.v
|
||||
if (typeof c == 'function') then c else throw new LispInterpreterError("Not a function: " + Object.toString(c))
|
||||
|
||||
ValueToPair = (e) ->
|
||||
c = e.content
|
||||
c = e.v
|
||||
if pairp c then c else throw new LispInterpreterError("Not a pair: " + Object.toString(c))
|
||||
|
||||
ValueToNumber = (e) ->
|
||||
c = e.content
|
||||
c = parseInt(e.v, 10)
|
||||
if (typeof c == 'number') then c else throw new LispInterpreterError("Not a number: " + Object.toString(c))
|
||||
|
||||
store_init = (a) -> throw new LispInterpreterError "No such address"
|
||||
env_init = (a) -> throw new LispInterpreterError "No such variable"
|
||||
|
||||
class Interpreter
|
||||
constructor: ->
|
||||
|
|
@ -109,7 +151,7 @@ class Interpreter
|
|||
|
||||
@definitial "cons", inValue arity_check "cons", 2, (values, kont, store) =>
|
||||
allocate store, 2, (store, addrs) =>
|
||||
kont (inValue (cons (car addr), (cadr addr))), (@extends store, addrs, values)
|
||||
kont (inValue (cons (car addr), (cadr addr))), (@lextends store, addrs, values)
|
||||
|
||||
@definitial "car", inValue arity_check "car", 1, (values, kont, store) =>
|
||||
kont (store car @valueToPair (car values)), store
|
||||
|
|
@ -117,15 +159,15 @@ class Interpreter
|
|||
@definitial "cdr", inValue arity_check "car", 1, (values, kont, store) =>
|
||||
kont (store cadr @valueToPair (car values)), store
|
||||
|
||||
@defprimitive "pair?", ((v) -> inValue (consp v.content)), 1
|
||||
@defprimitive "eq?", ((v1, v2) -> inValue (eq v1.content, v2.content)), 2
|
||||
@defprimitive "symbol?", ((v) -> inValue (symbolp v.content)), 1
|
||||
@defprimitive "pair?", ((v) -> inValue (consp v.v)), 1
|
||||
@defprimitive "eq?", ((v1, v2) -> inValue (eq v1.v, v2.v)), 2
|
||||
@defprimitive "symbol?", ((v) -> inValue (symbolp v.v)), 1
|
||||
|
||||
@definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) =>
|
||||
kont (car values), (@extend store, (car (ValueToPair (car values))), (cadr values))
|
||||
@definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) ->
|
||||
kont (car values), (extend store, (car (ValueToPair (car values))), (cadr values))
|
||||
|
||||
@definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) =>
|
||||
kont (car values), (@extend store, (cadr (ValueToPair (car values))), (cadr values))
|
||||
@definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) ->
|
||||
kont (car values), (extend store, (cadr (ValueToPair (car values))), (cadr values))
|
||||
|
||||
@defarithmetic "+", ((x, y) -> x + y), 2
|
||||
@defarithmetic "-", ((x, y) -> x - y), 2
|
||||
|
|
@ -140,7 +182,7 @@ class Interpreter
|
|||
|
||||
@definitial "apply", arity_check "apply", 2, inValue (values, kont, store) ->
|
||||
flat = (v) ->
|
||||
if pairp v.content
|
||||
if pairp v.v
|
||||
cons (store (car (ValueToPair v))), (flat (store (cadr (ValueToPair v))))
|
||||
else
|
||||
cons()
|
||||
|
|
@ -171,12 +213,11 @@ class Interpreter
|
|||
@definitial "visit", null
|
||||
@definitial "length", null
|
||||
@definitial "primes", null
|
||||
@loc = 0
|
||||
|
||||
loc: 0 # For allocate
|
||||
|
||||
listp: (cell) -> cell.__type == 'list'
|
||||
symbolp: (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] not in ["\"", ";"]
|
||||
atomp: (cell) -> not (cell.__type?) or (not cell.__type == 'list')
|
||||
symbolp: (cell) -> cell instanceof Symbol
|
||||
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] == "\""
|
||||
|
|
@ -190,20 +231,19 @@ class Interpreter
|
|||
mksymbols: (cell) -> cell
|
||||
|
||||
meaning: (e) ->
|
||||
meaningTable =
|
||||
"'": ((e) => @meaningQuotation (cadr e))
|
||||
'lambda': ((e) => @meaningAbstraction (cadr e), (cddr e))
|
||||
'if': ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))
|
||||
'begin': ((e) => @meaningSequence (cdr e))
|
||||
'set!': ((e) => @meaningAssignment (cadr e), (caddr e))
|
||||
|
||||
meaningTable = [
|
||||
[sQuote, ((e) => @meaningQuotation (cadr e))]
|
||||
[sLambda, ((e) => @meaningAbstraction (cadr e), (cddr e))]
|
||||
[sIf, ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))]
|
||||
[sBegin, ((e) => @meaningSequence (cdr e))]
|
||||
[sSet, ((e) => @meaningAssignment (cadr e), (caddr e))]
|
||||
]
|
||||
|
||||
if @atomp e
|
||||
if @symbolp e then (@meaningReference e) else (@meaningQuotation e)
|
||||
if (@atomp e)
|
||||
if (@symbolp e) then (@meaningReference e.name) else (@meaningQuotation e)
|
||||
else if meaningTable[(car e)]?
|
||||
meaningTable[(car e)](e)
|
||||
else
|
||||
found = (form[1] for form in forms when form[0](e))
|
||||
if found.length == 1 then found[0](e) else @meaningApplication (car e), (cdr e)
|
||||
@meaningApplication (car e), (cdr e)
|
||||
|
||||
meaningQuotation: (val) ->
|
||||
(env, kont, store) ->
|
||||
|
|
@ -244,23 +284,23 @@ class Interpreter
|
|||
if not (eq (length vals), (length names))
|
||||
throw new LispInterpreterError("Incorrect Arity.")
|
||||
functostore = (store2, addrs) =>
|
||||
(@meaningsSequence exps) (@extends env, names, addrs), kont1, (@extends store2, addrs, vals)
|
||||
(@meaningsSequence exps) (@lextends env, names, addrs), kont1, (@lextends store2, addrs, vals)
|
||||
allocate store1, (length names), functostore
|
||||
kont inValue, funcrep
|
||||
|
||||
meaningVariable: (name) ->
|
||||
(m) =>
|
||||
(vals, env, kont, store) =>
|
||||
allocate store, 1, (store, addrs) =>
|
||||
(m) ->
|
||||
(vals, env, kont, store) ->
|
||||
allocate store, 1, (store, addrs) ->
|
||||
addr = (car addrs)
|
||||
m (cdr vals), (@extend env, names, addr), kont, (@extend store, addr, (car vals))
|
||||
m (cdr vals), (extend env, names, addr), kont, (extend store, addr, (car vals))
|
||||
|
||||
meaningApplication: (exp, exps) ->
|
||||
(env, kont, store) =>
|
||||
hkont = (func, store1) =>
|
||||
kont2 = (values, store2) ->
|
||||
(ValueToFunction func) values, kont, store2
|
||||
(@meaning exps) env, kont2, store1
|
||||
(@meanings exps) env, kont2, store1
|
||||
(@meaning exp) env, hkont, store
|
||||
|
||||
meaningSequence: (exps) ->
|
||||
|
|
@ -285,52 +325,44 @@ class Interpreter
|
|||
meanings: (exps) =>
|
||||
meaningSomeArguments = (exp, exps) =>
|
||||
(env, kont, store) =>
|
||||
hkont = (value, store1) ->
|
||||
hkont = (value, store1) =>
|
||||
hkont2 = (values, store2) ->
|
||||
kont (cons value, values), store2
|
||||
(@meanings exps) env, khont2, store1
|
||||
(@meanings exps) env, hkont2, store1
|
||||
(@meaning exp) env, hkont, store
|
||||
|
||||
meaningNoArguments = (env, kont, store) -> (k (cons()), store)
|
||||
meaningNoArguments = ->
|
||||
(env, kont, store) ->
|
||||
kont (cons()), store
|
||||
|
||||
if pairp exps
|
||||
meaningSomeArguments (car exps), (cdr exps)
|
||||
else
|
||||
meaningNoArgument()
|
||||
|
||||
extend: (fn, pt, im) ->
|
||||
(x) -> if (eq pt, x) then im else (fn x)
|
||||
|
||||
extends: (fn, pts, ims) ->
|
||||
if (pairp pts)
|
||||
@extend (@extends fn, (cdr pts), (cdr ims)), (car pts), (car ims)
|
||||
else
|
||||
fn
|
||||
|
||||
store_init: (a) -> throw new LispInterpreterError "No such address"
|
||||
env_init: (a) -> throw new LispInterpreterError "No such variable"
|
||||
meaningNoArguments()
|
||||
|
||||
definitial: (name, value) ->
|
||||
allocate @store_init, 1, (store, addrs) =>
|
||||
@env_init = @extend @env_init, name, (car addrs)
|
||||
@store_init = @extend store, (car addrs), value
|
||||
allocate store_init, 1, (store, addrs) ->
|
||||
env_init = extend env_init, name, (car addrs)
|
||||
store_init = extend store, (car addrs), value
|
||||
name
|
||||
|
||||
defprimitive: (name, value, arity) ->
|
||||
callable = (values, kont, store) =>
|
||||
if not eq(arity, (length values))
|
||||
if not eq arity, (length values)
|
||||
throw new LispInterpreterError "Incorrect Arity for #{name}"
|
||||
kont (inValue (value.apply(@, [ValueToNumber(v) for v in values]))), store
|
||||
kont (inValue (value.apply(null, listToVector(values)))), store
|
||||
@definitial name, (inValue callable)
|
||||
|
||||
defarithmetic: (name, value, arity) ->
|
||||
callable = (values, kont, store) ->
|
||||
if not eq arity, (length values)
|
||||
throw new LispInterpreterError "Incorrect Arity for #{name}"
|
||||
kont (inValue (apply value, (map ValueToIngeter, values))), store
|
||||
(@defprimitive name, value, arity) (name), inValue callable
|
||||
kont (inValue (value.apply(null, listToVector(map values, ValueToNumber)))), store
|
||||
@definitial name, (inValue callable)
|
||||
|
||||
module.exports = (ast, kont) ->
|
||||
interpreter = new Interpreter()
|
||||
(meaning ast) @interpreter.env_init, (value, store_final) ->
|
||||
kont (convert value, store_final)
|
||||
store_current = store_init
|
||||
(interpreter.meaning ast)(env_init,
|
||||
((value, store_final) -> kont (convert value, store_final)), store_current)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue