[feat] Lambda-only interpreter. NOT WORKING.

.gitignore

@@ -10,6 +10,7 @@ bin/_mocha
 bin/mocha
 bin/coffee
 bin/cake
+bin/coffeelint
 test-reports.xml
 LisperatorLanguage
 chapter?/test.coffee

chapter4/interpreter.coffee

@@ -2,7 +2,7 @@
  cadr, caadr, cadar, caddr, nilp, nil, setcdr,
  metacadr, setcar} = require "cons-lists/lists"
 {normalizeForms, normalizeForm} = require "../chapter1/astToList"
-{Node, Symbol} = require '../chapter1/reader_types'
+{Node, Comment, Symbol} = require '../chapter1/reader_types'
 
 class LispInterpreterError extends Error
   name: 'LispInterpreterError'
@@ -27,79 +27,142 @@ astSymbolsToLispSymbols = (node) ->
 
 cadddr = metacadr('cadddr')
 
-metadata_evaluation =
+intlistp =     (node) -> node.type == 'list'
-  listp:     (node) -> node.type == 'list'
+intsymbolp =   (node) -> node.type == 'symbol'
-  symbolp:   (node) -> node.type == 'symbol'
+intnumberp =   (node) -> node.type == 'number'
-  numberp:   (node) -> node.type == 'number'
+intstringp =   (node) -> node.type == 'string'
-  stringp:   (node) -> node.type == 'string'
+intcommentp =  (node) -> node.type == 'comment'
-  commentp:  (node) -> node.type == 'comment'
+intnvalu =     (node) -> if (node.type == 'symbol') then node.value.name else node.value
-  nvalu:     (node) -> node.value
+intatomp =     (node) -> node.type in ['symbol', 'number', 'string']
-  mksymbols: (list) -> astSymbolsToLispSymbols(list)
+intmksymbols = (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'
+sBehavior = new Symbol 'behavior'
+sBoolean  = new Symbol 'boolean'
+sBoolify  = new Symbol 'boolify'
 sFunction = new Symbol 'function'
+sName     = new Symbol 'name'
+sNull     = new Symbol 'null'
+sTag      = new Symbol 'tag'
+sType     = new Symbol 'type'
+sValue    = new Symbol 'value'
+sPair     = new Symbol 'pair'
+sCar      = new Symbol 'car'
+sCdr      = new Symbol 'cdr'
+sSetCar   = new Symbol 'setcar'
+sSetCdr   = new Symbol 'setcdr'
+
+prox =
+  "quote":   (body, env, mem, kont) -> evaluateQuote (cadr body), env, mem, kont
+  "if":      (body, env, mem, kont) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont
+  "begin":   (body, env, mem, kont) -> evaluateBegin (cdr body), env, mem, kont
+  "set!":    (body, env, mem, kont) -> evaluateSet (intnvalu cadr body), (caddr body), env, mem, kont
+  "lambda":  (body, env, mem, kont) -> evaluateLambda (intmksymbols cadr body), (cddr body), env, mem, kont
+  "or":      (body, env, mem, kont) -> evaluateOr (car body), (cdr body), env, mem, kont
+
+#  ___          _           _
+# | __|_ ____ _| |_  _ __ _| |_ ___ _ _
+# | _|\ V / _` | | || / _` |  _/ _ \ '_|
+# |___|\_/\__,_|_|\_,_\__,_|\__\___/_|
+#
+
+transcode = (value, mem, qont) ->
+  forms = [
+    [intnullp, -> q theEmptyList, mem],
+    [((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> q (createBoolean value), mem)]
+    [intsymbolp, (-> q (createSymbol value), mem)]
+    [intnumberp, (-> q (createNumber value), mem)]
+    [intpairp,   (-> transcode (car intnvalu value), mem, (addr, mem2) ->
+      (transcode (cdr intvalu value), mem2, (d, mem3) ->
+        (allocatePair addr, d, mem3, qont)))]
+  ]
+  form = form[1] for form in forms when form[0](value)
+  if len(form) != 1
+    throw new LispInterpreterError "Bad form match for #{value}"
+  form[0]()
+
+
+evaluate = (exp, env, mem, kont) ->
+  if intatomp exp
+    if intsymbolp exp
+      evaluateVariable exp, env, mem, kont
+    else
+      evaluateQuote exp, env, mem, kont
+  else
+    body = intnvalu exp
+    head = car body
+    if prox[(intnvalu head)]?
+      prox[(intnvalu head)](body, env, mem, kont, ix)
+    else
+      evaluateApplication body, (cadr body), env, mem, kont
 
-# Page 129
 env_init = (id) -> throw LispInterpreterError "No binding for #{id}"
 
-# Page 129
+# This is basically the core definition of 'mem': it returns a
-# We don't have an initial value for mem yet?
+# function enclosing the address (a monotomically increasing number as
-update = (mem, addr, value) ->
+# memory is allocated) and the value.  Update is passed the current
-  (addra) -> if (addra == addr) then value else mem(addra)
+# memory, the address, and the value; it returns a function that says
+# "If the requested address is my address, return my value, otherwise
+# I'll call the memory handed to me at creation time with the address,
+# and it'll go down the line."  Update basically adds to a 'stack'
+# built entirely out of pointers to the base mem.
+
+update = (mem, addr, value) ->
+  (addra) -> if (eq 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
+# Memory location zero contains the position of the stack.
+
+expandStore = (highLocation, mem) ->
+  update mem, 0, highLocation
+
+mem_init = expandStore 0, (a) ->
+  throw new LispInterpreterError "No such address #{a}"
+
+newLocation = (mem) ->
+  (mem 0) + 1
+
 evaluateVariable = (name, env, mem, kont) ->
-  kont mem, (env name), mem
+  kont (mem (env name)), mem
 
-# Page 130
 evaluateSet = (name, exp, env, mem, kont) ->
-  evaluate exp, env, mem, (value, newmem) ->
+  evaluate exp, env, mem, (value, mem2) ->
-    kont value, (update newmem, (env name), value)
+    kont value, (update mem2, (env name), value)
 
-# Page 131
-# TODO: I don't know that I trust this.
 evaluateApplication = (exp, exprs, env, mem, kont) ->
 
+  # In chapter 3, this was a series of jumping continuations chasing
+  # each other.  Here, all of the continuations are kept in one place,
+  # and the argument list is built by tail-calls to evaluateArguments
+  # until the list is exhausted, at which point the continuation is
+  # called.  The continuation is built in the second paragraph below.
+
   evaluateArguments = (exprs, env, mem, kont) ->
     if (pairp exprs)
       evaluate (car exprs), env, mem, (value, mem2) ->
-        evaluateArguments (cdr exprs), env, mem2, (value2, mems3) ->
+        evaluateArguments (cdr exprs), env, mem2, (value2, mem3) ->
-          kont (cons value, value2), mems3
+          kont (cons value, value2), mem3
     else
       kont cons(), mem
 
-  evaluate exp, env, mem, (fun, mems) ->
+  evaluate exp, env, mem, (fun, mem2) ->
-    evaluateArguments exprs, env, mems, (value2, mem3) ->
+    evaluateArguments exprs, env, mem2, (value2, mem3) ->
       if eq (fun sType), sFunction
         (fun sBehavior) value2, mem3, kont
       else
         throw new LispInterpreterError "Not a function #{(car value2)}"
 
+# Creates a memory address for the function, then creates a new memory
+# address for each argument, then evaluates the expressions in the
+# lambda, returning the value of the last one.
+
 evaluateLambda = (names, exprs, env, mem, kont) ->
   allocate 1, mem, (addrs, mem2) ->
     kont (createFunction (car addrs), (values, mem, kont) ->
@@ -109,31 +172,22 @@ evaluateLambda = (names, exprs, env, mem, 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
+    evaluate ((env sBoolify) expt, expf), env, mems, kont
+
+evaluateQuote = (c, env, mem, kont) ->
+  transcode (normalizeForms c), mem, kont
+
+# By starting over "from here," we undo all side-effect assignments
+# that were effected by expression 1
+
+evaluateOr = (exp1, exp2, env, mem, kont) ->
+  evaluate exp1, env, mem, (value, mem2) ->
+    (value sBoolify) (-> kont value, mem2), (-> evaluate exp2, env, mem, kont)
 
-# Page 129
 # I like how, in this version, we explicitly throw away the meaning of
-# all but the last statement in evaluateBegin.  
+# all but the last statement in evaluateBegin.
 evaluateBegin = (exps, env, mem, kont) ->
   if pairp (cdr exps)
     evaluate (car exps), env, mem, (_, mems) ->
@@ -141,25 +195,216 @@ evaluateBegin = (exps, env, mem, kont) ->
   else
     evaluate (car exps), env, mem, kont
 
+theEmptyList = (msg) ->
+  switch msg
+    when sType then sNull
+    when sBoolify then (x, y) -> x
 
-prox = 
+createBoolean = (value) ->
-  "quote":   (body, env, mem, kont, ix) -> evaluateQuote (cadr body), env, mem, kont
+  combinator = if value then ((x, y) -> x) else ((x, y) -> y)
-  "if":      (body, env, mem, kont, ix) -> evaluateIf (cadr body), (caddr body), (cadddr body), env, mem, kont
+  (msg) ->
-  "begin":   (body, env, mem, kont, ix) -> evaluateBegin (cdr body), env, mem, kont
+    switch msg
-  "set!":    (body, env, mem, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, mem, kont
+      when sType then sBoolean
-  "lambda":  (body, env, mem, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, mem, kont
+      when sBoolify then combinator
 
-makeEvaluator = (ix = straight_evaluation) ->
+createSymbol = (value) ->
-  (exp, env, mem, kont) ->
+  (msg) ->
-    if ix.atomp exp
+    switch msg
-      if ix.symbolp exp
+      when sType then sValue
-        evaluateVariable exp, env, mem, kont
+      when sName then value
-      else
+      when sBoolify then (x, y) -> x
-        evaluateQuote exp, env, mem, kont
+
+createNumber = (value) ->
+  (msg) ->
+    switch msg
+      when sType then sNumber
+      when sValue then value
+      when sBoolify then (x, y) -> x
+
+createFunction = (tag, behavior) ->
+  (msg) ->
+    switch msg
+      when sType then sNumber
+      when sBoolify then (x, y) -> x
+      when sTag then tag
+      when sBehavior then behavior
+
+# I'm not sure I get the difference between allocate and update.
+# Update appears to have the power to append to the memory list
+# without updating highLocation.  If I'm reading this correct, then
+# what we're actually looking at is a simulation of a memory
+# subsystem, with expandStore/newLocation/allocate taking on the duty
+# of "managing" our stack, and update actually just doing the managing
+# the stack, and letting the garbage collector do its thing when a
+# pointer to memory function goes out of scope.  In short: the
+# allocate collection of functions is "going through the motions" of
+# managing memory; had this been a real memory manager, you'd have
+# a lot more work to do.
+
+allocate = (num, mem, q) ->
+  if (num > 0)
+    do ->
+      addr = newLocation mem
+      allocate (num - 1), (expandStore addr, mem), (addrs, mem2) ->
+        q (cons addr, addrs), mem2
+  else
+    q cons(), mem
+
+allocateList = (values, mem, q) ->
+  consify = (values, q) ->
+    if (pairp values)
+      consify (cdr values), (value, mem2) ->
+        allocatePair (car values), value, mem2, q
     else
-      body = ix.nvalu exp
+      q theEmptyList, mem
-      head = car body
+  consify values, q
-      if prox[(ix.nvalu head)]?
+
-        prox[(ix.nvalue head)](body, env, mem, kont, ix)
+allocatePair = (addr, d, mem, q) ->
+  allocate 2, mem, (addrs, mem2) ->
+    q (createPair (car addrs), (cadr addrs)), (update (update mem2, (car addrs), addr), (cadr addrs), d)
+
+createPair = (a, d) ->
+  (msg) ->
+    switch msg
+      when sType then sPair
+      when sBoolify then (x, y) -> x
+      when sSetCar then (mem, val) -> update mem, a, val
+      when sSetCdr then (mem, val) -> update mem, d, val
+      when sCar then a
+      when sCdr then d
+
+env_global = env_init
+mem_global = mem_init
+
+# The name is pushed onto the global environment, with a corresponding
+# address.  The address is pushed onto the current memory, with the
+# corresponding boxed value.
+
+defInitial = (name, value) ->
+  allocate 1, mem_global, (addrs, mem2) ->
+    env_global = update env_global, (new Symbol name), (car addrs)
+    mem_global = update mem2, (car addrs), value
+
+defPrimitive = (name, arity, value) ->
+  defInitial name, allocate 1, mem_global, (addrs, mem2) ->
+    mem_global = expandStore (car addrs), mem2
+    createFunction (car addrs), (values, mem, kont) ->
+      if (eq arity (length values))
+        value values, mem, kont
       else
-        evaluateApplication body, (cadr body), env, mem, kont
+        throw new LispInterpreterError "Wrong arity for #{name}"
+
+#  ___      _ _   _ _ _         _   _
+# |_ _|_ _ (_) |_(_) (_)_____ _| |_(_)___ _ _
+#  | || ' \| |  _| | | |_ / _` |  _| / _ \ ' \
+# |___|_||_|_|\__|_|_|_/__\__,_|\__|_\___/_||_|
+#
+
+
+defInitial "true", createBoolean true
+defInitial "false", createBoolean false
+defInitial "nil", null
+
+defPrimitive "<=", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createBoolean (((car values) sValue) <= ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Comparison requires numbers"
+
+defPrimitive "<", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createBoolean (((car values) sValue) < ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Comparison requires numbers"
+
+defPrimitive ">=", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createBoolean (((car values) sValue) >= ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Comparison requires numbers"
+
+defPrimitive ">", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createBoolean (((car values) sValue) > ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Comparison requires numbers"
+
+defPrimitive "=", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createBoolean (((car values) sValue) == ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Comparison requires numbers"
+
+defPrimitive "*", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createNumber (((car values) sValue) * ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Multiplication requires numbers"
+
+defPrimitive "+", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createNumber (((car values) sValue) + ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Addition requires numbers"
+
+defPrimitive "/", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createNumber (((car values) sValue) / ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Division requires numbers"
+
+defPrimitive "*", 2, (values, mem, kont) ->
+  if (eq ((car values) sType), sNumber) and (eq ((cadr values) sName), sNumber)
+    kont (createNumber (((car values) sValue) - ((cadr values) sValue))), mem
+  else
+    throw new LispInterpreterError "Subtraction requires numbers"
+
+defPrimitive "cons", 2, (values, mem, kont) ->
+  allocatePair (car values), (cadr values), mem, kont
+
+defPrimitive "car", 1, (values, mem, kont) ->
+  if (eq ((car values) sType) sPair)
+    kont (mem ((car values) sCar)), mem
+  else
+    throw new LispInterpreterError "Not a pair"
+
+defPrimitive "cdr", 1, (values, mem, kont) ->
+  if (eq ((car values) sType) sPair)
+    kont (mem ((car values) sCdr)), mem
+  else
+    throw new LispInterpreterError "Not a pair"
+
+defPrimitive "setcdr", 2, (values, mem, kont) ->
+  if (eq ((car values) sType) sPair)
+    pair = (car values)
+    kont pair, ((pair sSetCdr) mem, (cadr values))
+  else
+    throw new LispInterpreterError "Not a pair"
+
+defPrimitive "setcar", 2, (values, mem, kont) ->
+  if (eq ((car values) sType) sPair)
+    pair = (car values)
+    kont pair, ((pair sSetCar) mem, (cadr values))
+  else
+    throw new LispInterpreterError "Not a pair"
+
+defPrimitive "eqv?", (values, mem, kont) ->
+  kont createBoolean (
+    if (eq ((car values) sType) ((cadr values) sType))
+      switch ((car values) sType)
+        when sBoolean
+          ((car values) sBoolify) (((cadr values) sBoolify) true, false), (((cadr values) sBoolify) false, true)
+        when sSymbol
+          eq ((car values) sName), ((cadr values) sName)
+        when sNumber
+          ((car values) sName) == ((cadr values) sName)
+        when sPair
+          (((car values) sCar) == ((cadr values) sCar) and
+           ((car values) sCdr) == ((cadr values) sCdr))
+        when sFunction
+          ((car value) sTag) == ((cadr value) sTag)
+        else false
+    else false)
+
+module.exports = (ast, kont) ->
+  evaluate ast, env_global, mem_global, kont

chapter4/interpreter.js

@@ -1,255 +0,0 @@
-// 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);

test/test_chapter4.coffee

@@ -0,0 +1,40 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+olisp = require '../chapter4/interpreter'
+{read, readForms} = require '../chapter4/reader'
+
+the_false_value = (cons "false", "boolean")
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+describe "Core interpreter #4: Pure Lambda Memory", ->
+  it "Understands equality", ->
+    expect(lisp read "(eq? 'a 'b)").to.equal(false)
+    expect(lisp read "(eq? 'a 'a)").to.equal(true)
+    expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
+    expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true)
+    expect(lisp read "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true)
+    expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
+
+  it "Understands equivalence", ->
+    expect(lisp read "(eqv? '1 '2)").to.equal(false)
+    expect(lisp read "(eqv? 1 1)").to.equal(true)
+    expect(lisp read "(eqv? 'a 'b)").to.equal(false)
+    expect(lisp read "(eqv? 'a 'a)").to.equal(true)
+    expect(lisp read "(eqv? (cons 1 2) (cons 1 2))").to.equal(false)
+    expect(lisp read "((lambda (a) (eqv? a a)) (cons 1 2))").to.equal(true)
+    expect(lisp read "((lambda (a) (eqv? a a)) (lambda (x) x))").to.equal(true)
+    expect(lisp read "(eqv? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
+
+  it "Does special OR (backtracking without side-effect)", ->
+    expr1 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) \"OK\" \"KO\"))) 1)"
+    expect(lisp read expr1).to.equal("OK")
+    expr2 = "((lambda (x) (or (begin (set! x (+ x 1)) #f) (if (= x 1) (begin (set! x 3) x) \"KO\"))) 1)"
+    expect(lisp read expr2).to.equal(3)
+