Basic arithmetic works!

chapter5/interpreter5a.coffee

@@ -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 '../chapter5/reader_types'
-{Node, Comment, Symbol} = require '../chapter1/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()
+    aloop = (n, a) ->
-    n = num
+      if (n > 0)
-    until n <= 0
+        loc = loc - 1
-      loc = loc + 1
+        aloop (n - 1), (cons loc, a)
-      n = n - 1
+      else
-      cons loc, addrs
+        qont store, a
-    qont store, addrs)()
+    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 "pair?", ((v) -> inValue (consp v.v)), 1
-    @defprimitive "eq?", ((v1, v2) -> inValue (eq v1.content, v2.content)), 2
+    @defprimitive "eq?", ((v1, v2) -> inValue (eq v1.v, v2.v)), 2
-    @defprimitive "symbol?", ((v) -> inValue (symbolp v.content)), 1
+    @defprimitive "symbol?", ((v) -> inValue (symbolp v.v)), 1
   
-    @definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) =>
+    @definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) ->
-      kont (car values), (@extend store, (car (ValueToPair (car values))), (cadr values))
+      kont (car values), (extend store, (car (ValueToPair (car values))), (cadr values))
   
-    @definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) =>
+    @definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) ->
-      kont (car values), (@extend store, (cadr (ValueToPair (car values))), (cadr values))
+      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 = [
+    if (@atomp e)
-      [sQuote,  ((e) => @meaningQuotation (cadr e))]
+      if (@symbolp e) then (@meaningReference e.name) else (@meaningQuotation e)
-      [sLambda, ((e) => @meaningAbstraction (cadr e), (cddr e))]
+    else if meaningTable[(car e)]?
-      [sIf,     ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))]
+      meaningTable[(car e)](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)
     else
-      found = (form[1] for form in forms when form[0](e))
+      @meaningApplication (car e), (cdr e)
-      if found.length == 1 then found[0](e) else @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) =>
+    (m) ->
-      (vals, env, kont, store) =>
+      (vals, env, kont, store) ->
-        allocate store, 1, (store, addrs) =>
+        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()
+      meaningNoArguments()
-
-  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"
 
   definitial: (name, value) ->
-    allocate @store_init, 1, (store, addrs) =>
+    allocate store_init, 1, (store, addrs) ->
-      @env_init = @extend @env_init, name, (car addrs)
+      env_init = extend env_init, name, (car addrs)
-      @store_init = @extend store, (car addrs), value
+      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
+      kont (inValue (value.apply(null, listToVector(map values, ValueToNumber)))), store
-    (@defprimitive name, value, arity) (name), inValue callable
+    @definitial name, (inValue callable)
 
 module.exports = (ast, kont) ->
   interpreter = new Interpreter()
-  (meaning ast) @interpreter.env_init, (value, store_final) ->
+  store_current = store_init
-    kont (convert value, store_final)
+  (interpreter.meaning ast)(env_init,
+    ((value, store_final) -> kont (convert value, store_final)), store_current)