[feat] Chapter 5, first compiler. Not doing the rest...

This is a big change.  For chapter 5, I ripped out all line/column
tracking and most error handling from the parser; it's now a plain
ol' Lisp parser, and if it's not close to CL 22.1.1, it's a hell of
a lot closer than it used to be.

In doing so, I reduced the size of the parser by about 40 lines.

TrackingReader takes every function in a Reader and puts that
debugging information *back*.  It turns out that all that information
was prelude and postlude to the act of parsing; by wrapping each
function in a decorator I was able to restore all that information,
and I only had to get it right exactly *once*.

In functional programming terms, this lifts:

	IO -> (atom | list)

to:

	IO with tracking -> Node (atom | list) with tracking

It's a totally free win without having to do much extra work.

Now, this check-in isn't perfect.  The tracking reader is still
tossing on some things, and because I don't have a robust type
system (it is Coffeescript, after all), I'm having to do the
decorating and wrapping by hand.  But I'm definitely on my way
to understanding the issues, and having a grasp on functors and
monoids.

.gitignore

@@ -6,4 +6,11 @@ npm-debug.log
 package.yml
 node_modules/*
 tmp/
-test/
+bin/_mocha
+bin/mocha
+bin/coffee
+bin/cake
+bin/coffeelint
+test-reports.xml
+LisperatorLanguage
+chapter?/test.coffee

Makefile

@@ -0,0 +1,33 @@
+.PHONY: test
+
+# docs: $(patsubst %.md,%.html,$(wildcard *.md))
+
+SOURCES= chapter1/*.coffee chapter3/*.coffee chapter-lambda-1/*.coffee test/*.coffee
+
+%.js: src/%.coffee
+	node_modules/.bin/mocha coffee -c -o . $<
+
+%.html: %.md header.html footer.html
+	cat header.html > $@
+	pandoc $< >> $@
+	cat footer.html >> $@
+
+node_modules: package.json
+	mkdir -p node_modules
+	npm install
+
+lint:
+	coffeelint $(SOURCES)
+
+test: clean node_modules
+	@JUNIT_REPORT_PATH=test-reports.xml JUNIT_REPORT_STACK=1 ./node_modules/.bin/mocha \
+		--reporter mocha-jenkins-reporter --compilers coffee:coffee-script/register || true
+
+ltest: node_modules
+	node_modules/.bin/mocha --compilers coffee:coffee-script/register
+
+watch:
+	while inotifywait $(SOURCES) ; do make test; done
+
+clean: 
+	rm -f report.xml test-reports.xml

README.md

@@ -1,2 +1,37 @@
-Not much to see here.  Just practicing a few things.  If you're
-expecting miracles, this isn't the place for it.
+# A Collection of Interpreters from Lisp In Small Pieces, written in Coffeescript
+
+## Purpose
+
+I don't know Lisp, so I figured the correct place to start was to write
+my own interpreter.  After buying five different textbooks (*The
+Structure and Interpretation of Computer Programs*, aka "The Wizard
+Book", Friedman's *The Essentials of Programming Languages*, *Let over
+Lambda*, *On Lisp*, and one more) I decided Christian Quinnec's *Lisp In
+Small Pieces* gave the clearest step-by-step introduction.
+
+Since I didn't know Lisp, my task was to translate what Quiennec wrote
+in his book into a language I *did* know: Javascript.  Well,
+Coffeescript, which is basically Javascript with a lot of the
+syntactical noise removed, which is why I liked it.
+
+## Usage
+
+I don't know if you're going to get much out of it, but the reader
+(which I had to write by hand, seeing as I didn't *have* a native Lisp
+reader on hand in my Javascripty environment), and each interpreter has
+a fairly standard test case that demonstrates that each language does
+what it says it does: you can do math, set variables, name and create
+functions, and even do recursion.
+
+## Notes
+
+chapter-lambda-1 is not from Lisp In Small Pieces.  It is a primitive
+CPS interpreter built on top of the interpreter from LiSP Chapter 1,
+using techniques derived from a fairly facile reading of 
+<a href="http://lisperator.net/pltut/">Lisperator's "Implement A
+Programming Language in Javascript."</a>  But it was fun.
+
+## LICENSE AND COPYRIGHT NOTICE: NO WARRANTY GRANTED OR IMPLIED
+
+See the LICENSE file.
+

chapter-lambda-1/interpreter.coffee

@@ -0,0 +1,195 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
+ cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
+{Node} = require "../chapter1/reader_types"
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+env_init = nil
+env_global = env_init
+
+definitial = (name, value = nil) ->
+  env_global = (cons (cons name, value), env_global)
+  name
+
+defprimitive = (name, nativ, arity) ->
+  definitial name, ((args, callback) ->
+    vmargs = listToVector(args)
+    if (vmargs.length == arity)
+      callback nativ.apply null, vmargs
+    else
+      throw new LispInterpreterError "Incorrect arity")
+
+defpredicate = (name, nativ, arity) ->
+  defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), 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"
+
+defprimitive "cons", cons, 2
+defprimitive "car", car, 2
+defprimitive "set-cdr!", setcdr, 2
+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
+
+# MISTAKE: Variables are always of type Symbol.  This is probably a
+# mistake.
+
+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 (variables.type == 'symbol')
+      (cons (cons variables, values), env)
+    else
+      nil
+
+make_function = (variables, body, env, callback) ->
+  callback (values, cb) -> eprogn body, (extend env, variables, values), cb
+
+invoke = (fn, args, callback) ->
+  fn args, callback
+
+# 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, callback) ->
+  if (pairp exps)
+    if pairp (cdr exps)
+      evaluate (car exps), env, (next) ->
+        eprogn (cdr exps), env, callback
+    else
+      evaluate (car exps), env, callback
+  else
+    callback nil
+
+evlis = (exps, env, callback) ->
+  if (pairp exps)
+    evlis (cdr exps), env, (rest) ->
+      evaluate (car exps), env, (calc) ->
+        callback cons calc, rest
+  else
+    callback nil
+
+lookup = (id, env) ->
+  if (pairp env)
+    if (caar env) == id
+      cdar env
+    else
+      lookup id, (cdr env)
+  else
+    nil
+
+update = (id, env, value, callback) ->
+  if (pairp env)
+    if (caar env) == id
+      setcdr value, (car env)
+      callback value
+    else
+      update id, (cdr env), value, callback
+  else
+    callback 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.
+
+# TODO: Reengineer this with a call to normalize
+
+astSymbolsToLispSymbols = (node) ->
+  return nil if nilp node
+  throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
+  handler = (cell) ->
+    return nil if nilp cell
+    cons (car cell).value, (handler cdr cell)
+  handler node.value
+
+# Takes an AST node and evaluates it and its contents.  A node may be
+# ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
+
+cadddr = metacadr('cadddr')
+
+metadata_evaluation =
+  listp:     (node) -> node.type == 'list'
+  symbolp:   (node) -> node.type == 'symbol'
+  numberp:   (node) -> node.type == 'number'
+  stringp:   (node) -> node.type == 'string'
+  commentp:  (node) -> node.type == 'comment'
+  nvalu:     (node) -> node.value
+  mksymbols: (list) -> astSymbolsToLispSymbols(list)
+
+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
+
+makeEvaluator = (ix = straight_evaluation, ty="straight") ->
+  (exp, env, callback) ->
+    if ix.symbolp exp
+      return callback lookup (ix.nvalu exp), env
+    else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
+      return callback ix.nvalu exp
+    else if ix.listp exp
+      body = ix.nvalu exp
+      head = car body
+      if ix.symbolp head
+        return switch (ix.nvalu head)
+          when "quote" then callback cdr body
+          when "if"
+            evaluate (cadr body), env, (res) ->
+              w = unless res == the_false_value then caddr else cadddr
+              evaluate (w body), env, callback
+          when "begin" then eprogn (cdr body), env, callback
+          when "set!"
+            evaluate (caddr body), env, (newvalue) ->
+              update (ix.nvalu cadr body), env, newvalue, callback
+          when "lambda"
+            make_function (ix.mksymbols cadr body), (cddr body), env, callback
+          else
+            evaluate (car body), env, (fn) ->
+              evlis (cdr body), env, (args) ->
+                invoke fn, args, callback
+      else
+        evaluate (car body), env, (fn) ->
+          evlis (cdr body), env, (args) ->
+            invoke fn, args, callback
+    else
+      throw new LispInterpreterError ("Can't handle a #{type}")
+
+nodeEval = makeEvaluator(metadata_evaluation, "node")
+lispEval = makeEvaluator(straight_evaluation, "lisp")
+
+evaluate = (exp, env, cb) ->
+  (if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, cb)
+  
+module.exports = (c, cb) -> evaluate c, env_global, cb

chapter1/astAccessors.coffee

@@ -0,0 +1,10 @@
+{car, cdr, listp} = require 'cons-lists/lists'
+{Node, Symbol} = require "./reader_types"
+
+module.exports = ops =
+  astObject: (form) -> form instanceof Node
+  aValue:  (form) ->   form.value
+  aSymbol: (form) ->   form.value
+  isAList: (form) ->   ops.astObject(form) and form.type == 'list'
+  isARecord: (form) -> ops.astObject(form) and form.type == 'record'
+  isAVector: (form) -> ops.astObject(form) and form.type == 'vector'

chapter1/astToList.coffee

@@ -0,0 +1,56 @@
+{car, cdr, cons, listp, nilp, nil,
+ list, pairp, listToString} = require 'cons-lists/lists'
+{astObject} = require './astAccessors'
+{Symbol} = require './reader_types'
+
+# RICH_AST -> LISP_AST
+
+normalizeForm = (form) ->
+  
+  listToRecord1 = (l) ->
+    o = Object.create(null)
+    while(l != nil)
+      o[normalizeForm(car l)] = normalizeForm(car cdr l)
+      l = cdr cdr l
+      null
+    o
+
+  listToVector1 = (l) ->
+    while(l != nil) then p = normalizeForm(car l); l = cdr l; p
+
+  id = (a) -> a
+
+  methods =
+    'list': normalizeForms
+    'vector': (atom) -> listToVector1(atom)
+    'record': (atom) -> listToRecord1(atom)
+
+    # Basic native types.  Meh.
+    'symbol': (id) -> new Symbol(id.name)
+    'number': id
+    'string': id
+    'nil': (atom) -> nil
+
+    # Values inherited from the VM.
+    'true': (atom) -> true
+    'false': (atom) -> false
+    'null': (atom) -> null
+    'undefined': (atom) -> undefined
+
+  methods[form.type](form.value)
+
+
+normalizeForms = (forms) ->
+  # Yes, this reifies the expectation than an empty list and 'nil' are
+  # the same.
+  return nil if nilp forms
+
+  # Handle dotted list.
+  if (astObject forms)
+    return normalizeForm(forms)
+  cons(normalizeForm(car forms), normalizeForms(cdr forms))
+
+module.exports =
+  normalizeForm: normalizeForm
+  normalizeForms: normalizeForms
+

chapter1/interpreter.coffee

@@ -0,0 +1,185 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr,
+ cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
+{Node} = require "./reader_types"
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message, position = null) ->
+
+env_init = nil
+env_global = env_init
+
+definitial = (name, value = nil) ->
+  env_global = (cons (cons name, value), env_global)
+  name
+
+defprimitive = (name, nativ, arity) ->
+  definitial name, ((args) ->
+    vmargs = listToVector(args)
+    if (vmargs.length == arity)
+      nativ.apply null, vmargs
+    else
+      throw (new LispInterpreterError "Incorrect arity"))
+
+defpredicate = (name, nativ, arity) ->
+  defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), 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"
+
+defprimitive "cons", cons, 2
+defprimitive "car", car, 2
+defprimitive "set-cdr!", setcdr, 2
+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
+
+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 (variables.type == 'symbol')
+      (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
+
+# TODO: Reengineer this with a call to normalize
+
+tap = (i) -> console.log(i) ; i
+
+astSymbolsToLispSymbols = (node) ->
+  return nil if nilp node
+  throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
+  handler = (cell) ->
+    return nil if nilp cell
+    cons (car cell).value, (handler cdr cell)
+  handler node.value
+
+cadddr = metacadr('cadddr')
+
+# This is really the only thing that changes behavior between "reader
+# nodes" (nodes loaded with debugging metadata) and a standard cons
+# object.  TODO: astSymbolsToLispSymbols should be deprecated in
+# favor of normalizeForm (s?) and Symbol extraction
+
+metadata_evaluation =
+  listp:     (node) -> node.type == 'list'
+  symbolp:   (node) -> node.type == 'symbol'
+  numberp:   (node) -> node.type == 'number'
+  stringp:   (node) -> node.type == 'string'
+  commentp:  (node) -> node.type == 'comment'
+  nvalu:     (node) -> node.value
+  mksymbols: (list) -> astSymbolsToLispSymbols(list)
+
+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
+
+makeEvaluator = (ix = straight_evaluation, ty="straight") ->
+  (exp, env) ->
+    # Takes an AST node and evaluates it and its contents.  A node may be
+    # ("list" (... contents ...)) or ("number" 42) or ("symbol" x), etc.
+    if ix.symbolp(exp)
+      return lookup (ix.nvalu exp), env
+    else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
+      return ix.nvalu exp
+    else if ix.listp(exp)
+      body = ix.nvalu exp
+      head = car body
+      if ix.symbolp(head)
+        switch (ix.nvalu head)
+          when "quote" then cdr body
+          when "if"
+            unless (evaluate (cadr body), env) == the_false_value
+              evaluate (caddr body), env
+            else
+              evaluate (cadddr body), env
+          when "begin" then eprogn (cdr body), env
+          when "set!" then update (ix.nvalu cadr body), env, (evaluate (caddr body), env)
+          when "lambda" then make_function (ix.mksymbols cadr body), (cddr body), env
+          else invoke (evaluate (car body), env), (evlis (cdr body), env)
+      else
+        invoke (evaluate (car body), env), (evlis (cdr body), env)
+    else
+      throw new LispInterpreterError "Can't handle a #{exp.type}"
+
+nodeEval = makeEvaluator(metadata_evaluation, "node")
+lispEval = makeEvaluator(straight_evaluation, "lisp")
+
+evaluate = (exp, env) ->
+  (if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env)
+
+module.exports = (c) -> evaluate c, env_global

chapter1/reader.coffee

@@ -1,10 +1,12 @@
-{car, cdr, cons, nil, nilp, pairp, vectorToList} = require 'cons-lists/lists'
+{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
+{inspect} = require "util"
+{Node, Comment} = require "./reader_types"
 
 NEWLINES   = ["\n", "\r", "\x0B", "\x0C"]
 WHITESPACE = [" ", "\t"].concat(NEWLINES)
 
-EOF = new (class)
-EOO = new (class)
+EOF = new (class Eof)()
+EOO = new (class Eoo)()
 
 class Source
   constructor: (@inStream) ->
@@ -27,16 +29,12 @@ class Source
   done: -> @index > @max
 
 # IO -> IO
-skipWS = (inStream) -> 
+skipWS = (inStream) ->
   while inStream.peek() in WHITESPACE then inStream.next()
 
-# (type, value, line, column) -> (node {type, value, line, column)}
-makeObj = (type, value, line, column) ->
-  cons(type, cons(value, cons(line, cons(column, nil))))
-
 # msg -> (IO -> Node => Error)
 handleError = (message) ->
-  (line, column) -> makeObj('error', message, line, column)
+  (line, column) -> new Node('error', message, line, column)
 
 # IO -> Node => Comment
 readComment = (inStream) ->
@@ -45,7 +43,7 @@ readComment = (inStream) ->
     inStream.next()).join("")
   if not inStream.done()
     inStream.next()
-  makeObj 'comment', r, line, column
+  new Node 'comment', (new Comment r), line, column
 
 # IO -> (Node => Literal => String) | Error
 readString = (inStream) ->
@@ -58,7 +56,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
+  new Node 'string', (string.join ''), line, column
 
 # (String) -> (Node => Literal => Number) | Nothing
 readMaybeNumber = (symbol) ->
@@ -84,9 +82,9 @@ readSymbol = (inStream, tableKeys) ->
     inStream.next()).join ''
   number = readMaybeNumber symbol
   if number?
-    return makeObj 'number', number, line, column
-  makeObj 'symbol', symbol, line, column
-  
+    return new Node 'number', number, line, column
+  new Node 'symbol', symbol, line, column
+
 
 # (Delim, TypeName) -> IO -> (IO, node) | Error
 makeReadPair = (delim, type) ->
@@ -97,18 +95,25 @@ makeReadPair = (delim, type) ->
     [line, column] = inStream.position()
     if inStream.peek() == delim
       inStream.next()
-      return makeObj(type, nil, line, column)
+      return new Node type, nil, line, column
 
     # IO -> (IO, Node) | Error
+    dotted = false
     readEachPair = (inStream) ->
       [line, column] = inStream.position()
       obj = read inStream, true, null, true
-      if inStream.peek() == delim then return cons obj, nil
+      if inStream.peek() == delim
+        if dotted then return obj
+        return cons obj, nil
       if inStream.done() then return handleError("Unexpected end of input")(line, column)
-      return obj if (car obj) == 'error'
-      cons obj, readEachPair(inStream)
+      if dotted then return handleError("More than one symbol after dot")
+      return obj if obj.type == 'error'
+      if obj.type == 'symbol' and obj.value == '.'
+        dotted = true
+        return readEachPair inStream
+      cons obj, readEachPair inStream
 
-    ret = makeObj type, readEachPair(inStream), line, column
+    ret = new Node type, readEachPair(inStream), line, column
     inStream.next()
     ret
 
@@ -120,8 +125,8 @@ prefixReader = (type) ->
     inStream.next()
     [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
+    return obj if obj.type == 'error'
+    new Node "list", cons((new Node("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
@@ -134,7 +139,7 @@ readMacros =
   '[': makeReadPair ']', 'vector'
   ']': handleError "Closing bracket encountered"
   '{': makeReadPair('}', 'record', (res) ->
-      res.length % 2 == 0 and true or mkerr "record key without value")
+    res.length % 2 == 0 and true or mkerr "record key without value")
   '}': handleError "Closing curly without corresponding opening."
   "`": prefixReader 'back-quote'
   "'": prefixReader 'quote'
@@ -168,7 +173,7 @@ read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadM
 
   while true
     form = matcher inStream, c
-    skip = (not nilp form) and (car form == 'comment') and not keepComments
+    skip = (not nilp form) and (form.type == 'comment') and not keepComments
     break if (not skip and not nilp form) or inStream.done()
     c = inStream.peek()
     null
@@ -179,19 +184,21 @@ read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadM
 
 # IO -> (Form* | Error)
 readForms = (inStream) ->
-    inStream = if inStream instanceof Source then inStream else new Source inStream
-    return nil if inStream.done()
+  inStream = if inStream instanceof Source then inStream else new Source inStream
+  return nil if inStream.done()
 
-    # IO -> (FORM*, IO) | Error
-    [line, column] = inStream.position()
-    readEach = (inStream) ->
-      obj = read inStream, true, null, false
-      return nil if (nilp obj)
-      return obj if (car obj) == 'error'
-      cons obj, readEach inStream
+  # IO -> (FORM*, IO) | Error
+  [line, column] = inStream.position()
+  readEach = (inStream) ->
+    obj = read inStream, true, null, false
+    return nil if (nilp obj)
+    return obj if obj.type == 'error'
+    cons obj, readEach inStream
 
-    obj = readEach inStream
-    if (car obj) == 'error' then obj else makeObj "list", obj, line, column
+  obj = readEach inStream
+  if obj.type == 'error' then obj else new Node "list", obj, line, column
 
 exports.read = read
 exports.readForms = readForms
+exports.Node = Node
+exports.Symbol = Symbol

chapter1/reader_types.coffee

@@ -0,0 +1,11 @@
+exports.Node = class
+  constructor: (@type, @value, @line, @column) ->
+
+exports.Symbol = class
+  constructor: (@name) ->
+    
+exports.Comment = class
+  constructor: (@text) ->
+
+
+          

chapter3/interpreter.coffee

@@ -0,0 +1,448 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
+ cadr, caadr, cadar, caddr, nilp, nil, setcdr,
+ metacadr, setcar} = require "cons-lists/lists"
+{normalizeForms, normalizeForm} = require "../chapter1/astToList"
+{Node, Symbol} = require '../chapter1/reader_types'
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+the_false_value = (cons "false", "boolean")
+
+# Base class that represents a value.  Base class representing a LiSP
+# value, a primitive, or a function
+
+eq = (id1, id2) ->
+  if id1 instanceof Symbol and id2 instanceof Symbol
+    return id1.name == id2.name
+  id1 == id2
+
+class Value
+
+# Represents the base class of a continuation.  Calls to invoke resume
+# the contained continuation, which is typecast to one of the specific
+# continuation needs of conditional, sequence, etc...
+
+class Continuation
+  constructor: (@kont) ->
+  invoke: (value, env, kont) ->
+    if nilp cdr value
+      @kont.resume (car value)
+    else
+      throw new LispInterpreterError "Continuations expect one argument"
+  unwind: (value, ktarget) ->
+    if (@kont == ktarget) then (@kont.resume value) else (@kont.unwind value, ktarget)
+  catchLookup: (tag, kk) ->
+    @kont.catchLookup tag, kk
+
+# Abstract class representing the environment
+
+class Environment
+  lookup: -> throw new LispInterpreterError "Nonspecific invocation"
+  update: -> throw new LispInterpreterError "Nonspecific invocation"
+  blockLookup: -> throw new LispInterpreterError "Not an Environment"
+
+# Base of the environment stack.  If you hit this, your variable was
+# never found for lookup/update.  Note that at this time in the
+# class, you have not
+
+class NullEnv extends Environment
+  lookup: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
+  update: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
+  blockLookup: (name) -> throw new LispInterpreterError "Unknown block label #{name}"
+
+# This appears to be an easy and vaguely abstract handle to the
+# environment.  The book is not clear on the distinction between the
+# FullEnv and the VariableEnv.
+
+class FullEnv extends Environment
+  constructor: (@others, @name) ->
+    @_type = "FullEnv"
+  lookup: (name, kont) ->
+    @others.lookup name, kont
+  update: (name, kont, value) ->
+    @others.update name, kont, value
+  blockLookup: (name, kont, value) ->
+    @others.blockLookup(name, kont, value)
+
+# This is the classic environment pair; either it's *this*
+# environment, or it's a parent environment, until you hit the
+# NullEnv.  Once the name has been found, the continuation is called
+# with the found value.
+
+class VariableEnv extends FullEnv
+  constructor: (@others, @name, @value) ->
+    @_type = "VariableEnv"
+  lookup: (name, kont) ->
+    if name == @name
+      kont.resume @value
+    else
+      @others.lookup name, kont
+  update: (name, kont, value) ->
+    if name == @name
+      @value = value
+      kont.resume value
+    else
+      @others.update name, kont, value
+
+# "Renders the quote term to the current continuation"; in a more
+# familiar parlance, calls resume in the current context with the
+# quoted term uninterpreted.
+
+evaluateQuote = (v, env, kont) ->
+  kont.resume normalizeForms v
+
+# Evaluates the conditional expression, creating a continuation with
+# the current environment that, when resumed, evaluates either the
+# true or false branch, again in the current enviornment.
+
+evaluateIf = (exps, env, kont) ->
+  evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
+
+
+class IfCont extends Continuation
+  constructor: (@kont, @ift, @iff, @env) ->
+    @_type = "IfCont"
+  resume: (value) ->
+    evaluate (if value == the_false_value then @iff else @ift), @env, @kont
+
+# Sequences: evaluates the current expression with a continuation that
+# represents "the next expression" in the sequence.  Upon resumption,
+# calls this function with that next expression.
+
+evaluateBegin = (exps, env, kont) ->
+  if (pairp exps)
+    if pairp (cdr exps)
+      evaluate (car exps), env, (new BeginCont kont, exps, env)
+    else
+      evaluate (car exps), env, kont
+  else
+    kont.resume("Begin empty value")
+
+class BeginCont extends Continuation
+  constructor: (@kont, @exps, @env) ->
+    @_type = "BeginCont"
+  resume: (v) -> evaluateBegin (cdr @exps), @env, @kont
+
+# In this continuation, we simply pass the continuation and the name
+# to the environment to look up.  The environment knows to call the
+# continuation with the value.
+
+evaluateVariable = (name, env, kont) ->
+  env.lookup(name, kont)
+
+# This is the same dance as lookup, only with the continuation being
+# called after an update has been performed.
+
+evaluateSet = (name, exp, env, kont) ->
+  evaluate exp, env, (new SetCont(kont, name, env))
+
+class SetCont extends Continuation
+  constructor: (@kont, @name, @env) ->
+    @_type = "SetCont"
+  resume: (value) ->
+    @env.update @name, @kont, value
+
+# Calls the current contunation, passing it a new function wrapper.
+
+evaluateLambda = (names, exp, env, kont) ->
+  kont.resume new Function names, exp, env
+
+# Upon invocation, evaluates the body with a new environment that
+# consists of the original names, their current values as called, and
+# the continuation an the moment of invocation, which will continue
+# (resume) execution once the function is finished.
+#
+# By the way: this is pretty much the whole the point.
+
+class Function extends Value
+  constructor: (@variables, @body, @env) ->
+    @_type = "Function"
+  invoke: (values, env, kont) ->
+    evaluateBegin @body, (extend @env, @variables, values), kont
+
+# Helper function to build name/value pairs for the current execution
+# context.
+
+extend = (env, names, values) ->
+  if (pairp names) and (pairp values)
+    new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
+  else if (nilp names)
+    if (nilp values) then env else throw new LispInterpreterError "Arity mismatch"
+  else
+    new VariableEnv env, names, values
+
+# Now we start the invocation: this is applying the function.  Let's
+# take it stepwise.
+
+# Create a function environment.  Calls the evaluateArguments(), which
+# in turns goes down the list of arguments and creates a new
+# environment, and then the continuation is to actually appy the nev
+# environment to the existing function.
+
+evaluateApplication = (exp, exps, env, kont) ->
+  evaluate exp, env, (new EvFunCont kont, exps, env)
+
+class EvFunCont extends Continuation
+  constructor: (@kont, @exp, @env) ->
+    @_type = "EvFunCont"
+  resume: (f) ->
+    evaluateArguments @exp, @env, (new ApplyCont(@kont, f, @env))
+
+# Evaluate the first list, creating a new list of the arguments.  Upon
+# completion, resume the continuation with the gather phase
+
+evaluateArguments = (exp, env, kont) ->
+  if (pairp exp)
+    evaluate (car exp), env, (new ArgumentCont kont, exp, env)
+  else
+    kont.resume(nil)
+
+class ArgumentCont extends Continuation
+  constructor: (@kont, @exp, @env) ->
+    @_type = "ArgumentCont"
+  resume: (v) ->
+    evaluateArguments (cdr @exp), @env, (new GatherCont @kont, v)
+
+# Gather the arguments as each ArgumentCont is resumed into a list to
+# be passed to our next step.
+
+class GatherCont extends Continuation
+  constructor: (@kont, @value) ->
+    @_type = "GatherCont"
+  resume: (value) ->
+    @kont.resume (cons @value, value)
+
+# Upon resumption, invoke the function.
+
+class ApplyCont extends Continuation
+  constructor: (@kont, @fn, @env) ->
+    @_type = "ApplyCont"
+  resume: (value) ->
+    @fn.invoke value, @env, @kont
+
+# A special continuation that represents what we want the interpreter
+# to do when it's done processing.
+
+class BottomCont extends Continuation
+  constructor: (@kont, @func) ->
+    @_type = "BottomCont"
+  resume: (value) ->
+    @func(value)
+  unwind: (value, ktarget) ->
+    throw new LispInterpreterError "Obsolete continuation"
+  catchLookup: (tag, kk) ->
+    throw new LispInterpreterError "No associated catch"
+
+evaluateBlock = (label, body, env, kont) ->
+  k = new BlockCont(kont, label)
+  evaluateBegin body, (new BlockEnv env, label, kont), k
+
+class BlockCont extends Continuation
+  constructor: (@kont, @label) ->
+    @_type = "BlockCont"
+  resume: (value) ->
+    @kont.resume value
+
+class BlockEnv extends FullEnv
+  constructor: (@others, @name, @kont) ->
+  blockLookup: (name, kont, value) ->
+    if (name == @name)
+      kont.unwind value, @kont
+    else
+      @others.blockLookup(name, kont, value)
+
+evaluateReturnFrom = (label, form, env, kont) ->
+  evaluate form, env, (new ReturnFromCont kont, env, label)
+
+class ReturnFromCont extends Continuation
+  constructor: (@kont, @env, @label) ->
+  resume: (v) ->
+    @env.blockLookup @label, @kont, v
+
+evaluateCatch = (tag, body, env, kont) ->
+  evaluate tag, env, (new CatchCont kont, body, env)
+
+class CatchCont extends Continuation
+  constructor: (@kont, @body, @env) ->
+  resume: (value) ->
+    evaluateBegin @body, @env, (new LabeledCont @kont, value)
+
+class LabeledCont extends Continuation
+  constructor: (@kont, @tag) ->
+  resume: (value) ->
+    @kont.resume value
+  catchLookup: (tag, kk) ->
+    if eq tag, @tag
+      evaluate kk.form, kk.env, (new ThrowingCont kk, tag, this)
+    else
+      @kont.catchLookup tag, kk
+
+class ThrowCont extends Continuation
+  constructor: (@kont, @form, @env) ->
+  resume: (value) ->
+    @catchLookup value, @
+  
+evaluateThrow = (tag, form, env, kont) ->
+  evaluate tag, env, (new ThrowCont kont, form, env)
+
+class ThrowingCont extends Continuation
+  constructor: (@kont, @tag, @resumecont) ->
+  resume: (value) ->
+    @resumecont.resume value
+
+evaluateUnwindProtect = (form, cleanup, env, kont) ->
+  evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
+
+class UnwindProtectCont extends Continuation
+  constructor: (@kont, @cleanup, @env) ->
+  resume: (value) ->
+    evaluateBegin @cleanup, @env, (new ProtectReturnCont @kont, value)
+
+class Primitive extends Value
+  constructor: (@name, @nativ) ->
+    @_type = "Primitive"
+  invoke: (args, env, kont) ->
+    @nativ.apply null, [args, env, kont]
+
+env_init = new NullEnv()
+
+definitial = (name, value = nil) ->
+  env_init = new VariableEnv env_init, name, value
+  name
+
+defprimitive = (name, nativ, arity) ->
+  definitial name, new Primitive name, (args, env, kont) ->
+    vmargs = listToVector(args)
+    if (vmargs.length == arity)
+      kont.resume (nativ.apply null, vmargs)
+    else
+      throw new LispInterpreterError "Incorrect arity"
+
+defpredicate = (name, nativ, arity) ->
+  defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
+
+definitial "#t", true
+definitial "#f", the_false_value
+definitial "nil", nil
+
+# FIXME: All of these things dereference to the same value!!!!
+
+for i in [
+  "x", "y", "z", "a", "b", "c", "foo", "bar", "hux",
+  "fib", "fact", "visit", "primes", "length"]
+  definitial i
+
+defprimitive "cons", cons, 2
+defprimitive "car", car, 2
+defprimitive "cdr", cdr, 2
+defprimitive "set-cdr!", setcdr, 2
+defprimitive "set-car!", setcar, 2
+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 "gt", ((a, b) -> a > b), 2
+defpredicate "lte", ((a, b) -> a <= b), 2
+defpredicate "gte", ((a, b) -> a >= b), 2
+defpredicate "eq?", ((a, b) -> a == b), 2
+defpredicate "pair?", ((a) -> pairp a), 1
+defpredicate "nil?", ((a) -> nilp a), 1
+defpredicate "symbol?", ((a) -> /\-?[0-9]+$/.test(a) == false), 1
+
+definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
+  if nilp cdr values
+    (car values).invoke (cons kont), env, kont
+  else
+    throw new LispInterpreterError "Incorrect arity for call/cc"
+
+definitial "apply", new Primitive "apply", (values, env, kont) ->
+  if pairp cdr values
+    f = car values
+    args = (() ->
+      (flat = (args) ->
+        if nilp (cdr args) then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
+    f.invoke args, env, kont
+
+definitial "funcall", new Primitive "funcall", (args, env, kont) ->
+  if not nilp cdr args
+    @kont.invoke (car args), (cdr args)
+  else
+    throw new LispInterpreterError "Invoke requires a function name and arguments"
+
+definitial "list", new Primitive "list", (values, env, kont) ->
+  (values, env, kont) -> kont.resume(values)
+
+# Only called in rich node mode...
+
+astSymbolsToLispSymbols = (node) ->
+  return nil if nilp node
+  throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
+  handler = (cell) ->
+    return nil if nilp cell
+    cons (car cell).value, (handler cdr cell)
+  handler node.value
+
+metadata_evaluation =
+  listp:     (node) -> node.type == 'list'
+  symbolp:   (node) -> node.type == 'symbol'
+  numberp:   (node) -> node.type == 'number'
+  stringp:   (node) -> node.type == 'string'
+  commentp:  (node) -> node.type == 'comment'
+  nvalu:     (node) -> node.value
+  mksymbols: (list) -> astSymbolsToLispSymbols(list)
+
+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
+
+makeEvaluator = (ix = straight_evaluation, ty="straight") ->
+  (exp, env, kont) ->
+    if ix.symbolp exp
+      return evaluateVariable (ix.nvalu exp), env, kont
+    else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
+      return kont.resume ix.nvalu exp
+    else if ix.listp exp
+      body = ix.nvalu exp
+      head = car body
+      if ix.symbolp head
+        switch (ix.nvalu head)
+          when "quote" then evaluateQuote (cadr body), env, kont
+          when "if" then evaluateIf (cdr body), env, kont
+          when "begin" then evaluateBegin (cdr body), env, kont
+          when "set!" then evaluateSet (ix.nvalu cadr body), (caddr body), env, kont
+          when "lambda" then evaluateLambda (ix.mksymbols cadr body), (cddr body), env, kont
+          when "block" then evaluateBlock (ix.nvalu cadr body), (cddr body), env, kont
+          when "return-from" then evaluateReturnFrom (ix.nvalu cadr body), (caddr body), env, kont
+          when "catch" then evaluateCatch (cadr body), (cddr body), env, kont
+          when "throw" then evaluateThrow (cadr body), (caddr body), env, kont
+          when "unwind-protect" then evaluateUnwindProtect (cadr body), (cddr body), env, kont
+          else evaluateApplication (car body), (cdr body), env, kont
+      else
+        evaluateApplication (car body), (cdr body), env, kont
+    else
+      throw new LispInterpreterError("Can't handle a '#{type}'")
+  
+nodeEval = makeEvaluator(metadata_evaluation, "node")
+lispEval = makeEvaluator(straight_evaluation, "lisp")
+
+evaluate = (exp, env, kont) ->
+  (if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, kont)
+
+interpreter = (ast, kont) ->
+  evaluate ast, env_init, new BottomCont null, kont
+
+module.exports = interpreter

chapter3g/interpreter.coffee

@@ -0,0 +1,549 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
+ cadr, caadr, cadar, caddr, nilp, nil, setcdr,
+ metacadr, setcar} = require "cons-lists/lists"
+{normalizeForms, normalizeForm} = require "../chapter1/astToList"
+{Node, Symbol} = require '../chapter1/reader_types'
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+the_false_value = (cons "false", "boolean")
+
+# An equality function that compares two values.  This is necessary
+# because object comparison in Javascipt is by reference, not by value.
+# I want them to be by value, and this accomplishes that in this one
+# special case.
+
+eq = (id1, id2) ->
+  if id1 instanceof Symbol and id2 instanceof Symbol
+    return id1.name == id2.name
+  id1 == id2
+
+# Base class that represents a value.  Base class representing a LiSP
+# value, a primitive, or a function
+
+class Value
+
+# Represents the base class of a continuation.  
+
+class Continuation
+  # Takes an existing continuation, which represents what to do when
+  # this continuation is invoked.
+  constructor: (@kont) ->
+
+  # Near as I can tell, this exists strictly to support call/cc
+  invoke: (value, env, kont) ->
+    if nilp cdr value
+      @kont.resume (car value)
+    else
+      throw new LispInterpreterError "Continuations expect one argument"
+
+  # As we're unwinding the stack, when we receive a new ktarget we've
+  # "breached" where this protection was created and need to resume the
+  # continuation passed there.
+  unwind: (value, ktarget) ->
+    if (@ == ktarget) then (@kont.resume value) else (@kont.unwind value, ktarget)
+
+  # When a throw happens, we need to proceed down the stack looking
+  # for a CatchContinuation.  This supports that for all continuations.
+  catchLookup: (tag, kk) ->
+    @kont.catchLookup tag, kk
+
+  # Resume is literally the "What to do next."  
+  resume: (value) ->
+    throw new LispInterpreterError "Wrong continuation for #{@_type}"
+
+# Abstract class representing the environment
+
+class Environment
+  lookup: -> throw new LispInterpreterError "Nonspecific invocation"
+  update: -> throw new LispInterpreterError "Nonspecific invocation"
+  blockLookup: -> throw new LispInterpreterError "Not an Environment"
+
+# Base of the environment stack.  If you hit this, your variable was
+# never found for lookup/update.  Note that at this time in the
+# class, you have not
+
+class NullEnv extends Environment
+  lookup: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
+  update: (e) -> throw new LispInterpreterError "Unknown variable #{e}"
+  blockLookup: (name) -> throw new LispInterpreterError "Unknown block label #{name}"
+
+# This appears to be an easy and vaguely abstract handle to the
+# environment.  The book is not clear on the distinction between the
+# FullEnv and the VariableEnv.
+
+class FullEnv extends Environment
+  constructor: (@others, @name) ->
+    @_type = "FullEnv"
+  lookup: (name, kont) ->
+    @others.lookup name, kont
+  update: (name, kont, value) ->
+    @others.update name, kont, value
+  blockLookup: (name, kont, value) ->
+    @others.blockLookup(name, kont, value)
+
+# This is the classic environment pair; either it's *this*
+# environment, or it's a parent environment, until you hit the
+# NullEnv.  Once the name has been found, the continuation is called
+# with the found value.
+
+class VariableEnv extends FullEnv
+  constructor: (@others, @name, @value) ->
+    @_type = "VariableEnv"
+  lookup: (name, kont) ->
+    if name == @name
+      kont.resume @value
+    else
+      @others.lookup name, kont
+  update: (name, kont, value) ->
+    if name == @name
+      @value = value
+      kont.resume value
+    else
+      @others.update name, kont, value
+
+# "Renders the quote term to the current continuation"; in a more
+# familiar parlance, calls resume in the current context with the
+# quoted term uninterpreted.
+
+evaluateQuote = (v, env, kont) ->
+  kont.resume normalizeForms v
+
+# Evaluates the conditional expression, creating a continuation with
+# the current environment that, when resumed, evaluates either the
+# true or false branch, again in the current enviornment.
+
+evaluateIf = (exps, env, kont) ->
+  evaluate (car exps), env, new IfCont(kont, (cadr exps), (caddr exps), env)
+
+class IfCont extends Continuation
+  constructor: (@kont, @ift, @iff, @env) ->
+    @_type = "IfCont"
+  resume: (value) ->
+    evaluate (if value == the_false_value then @iff else @ift), @env, @kont
+
+# Sequences: evaluates the current expression with a continuation that
+# represents "the next expression" in the sequence.  Upon resumption,
+# calls this function with that next expression.  You can begin to
+# note how the "what to do next" gets wrapped in deeper and deeper
+# layers of context until the current needs are resolved and we
+# finally reach that final expression.
+
+evaluateBegin = (exps, env, kont) ->
+  if (pairp exps)
+    if pairp (cdr exps)
+      evaluate (car exps), env, (new BeginCont kont, exps, env)
+    else
+      evaluate (car exps), env, kont
+  else
+    kont.resume("Begin empty value")
+
+class BeginCont extends Continuation
+  constructor: (@kont, @exps, @env) ->
+    @_type = "BeginCont"
+  resume: (v) -> evaluateBegin (cdr @exps), @env, @kont
+
+# In this continuation, we simply pass the continuation and the name
+# to the environment to look up.  The environment knows to call the
+# continuation with the value.
+
+evaluateVariable = (name, env, kont) ->
+  env.lookup(name, kont)
+
+# This is the same dance as lookup, only with the continuation being
+# called after an update has been performed.
+
+evaluateSet = (name, exp, env, kont) ->
+  evaluate exp, env, (new SetCont(kont, name, env))
+
+class SetCont extends Continuation
+  constructor: (@kont, @name, @env) ->
+    @_type = "SetCont"
+  resume: (value) ->
+    @env.update @name, @kont, value
+
+# Calls the current contunation, passing it a new function wrapper.
+
+evaluateLambda = (names, exp, env, kont) ->
+  kont.resume new Function names, exp, env
+
+# Upon invocation, evaluates the body with a new environment that
+# consists of the original names, their current values as called, and
+# the continuation an the moment of invocation, which will continue
+# (resume) execution once the function is finished.
+#
+# By the way: this is pretty much the whole the point.
+
+class Function extends Value
+  constructor: (@variables, @body, @env) ->
+    @_type = "Function"
+  invoke: (values, env, kont) ->
+    evaluateBegin @body, (extend @env, @variables, values), kont
+
+# Helper function to build name/value pairs for the current execution
+# context.
+
+extend = (env, names, values) ->
+  if (pairp names) and (pairp values)
+    new VariableEnv (extend env, (cdr names), (cdr values)), (car names), (car values)
+  else if (nilp names)
+    if (nilp values) then env else throw new LispInterpreterError "Arity mismatch"
+  else
+    new VariableEnv env, names, values
+
+# Now we start the invocation: this is applying the function.  Let's
+# take it stepwise.
+
+# Evaluate the application of a function call.  The first step is to
+# evaluate the first element of the function call, assuming it is or
+# will resolve to a function (something of type * -> *).  The
+# continuation we create is to evaluate-function-cont.
+
+evaluateApplication = (exp, exps, env, kont) ->
+  evaluate exp, env, (new EvFunCont kont, exps, env)
+
+# After the function reference is finally generated, the resume()
+# function here takes that reference and creates an
+# apply-continuation, then calls evaluateArguments.  See that.
+
+class EvFunCont extends Continuation
+  constructor: (@kont, @exp, @env) ->
+    @_type = "EvFunCont"
+  resume: (f) ->
+    evaluateArguments @exp, @env, (new ApplyCont(@kont, f, @env))
+
+# Evaluate the argument list, creating a new list of the arguments.
+# For each argument pair, in calls the gather-cont, which creates the
+# actual pair and resumes by processing the next pair, building the
+# new environment.  When the list is exhausted, the EvFunCont's built
+# ApplyCont() is called with the generated new environment and its
+# associated thunk.
+
+evaluateArguments = (exp, env, kont) ->
+  if (pairp exp)
+    evaluate (car exp), env, (new ArgumentCont kont, exp, env)
+  else
+    kont.resume(nil)
+
+class ArgumentCont extends Continuation
+  constructor: (@kont, @exp, @env) ->
+    @_type = "ArgumentCont"
+  resume: (v) ->
+    evaluateArguments (cdr @exp), @env, (new GatherCont @kont, v)
+
+# Gather the arguments as each ArgumentCont is resumed into a list to
+# be passed to our next step.
+
+class GatherCont extends Continuation
+  constructor: (@kont, @value) ->
+    @_type = "GatherCont"
+  resume: (value) ->
+    @kont.resume (cons @value, value)
+
+# Called with the new environment, and the orginal continuation that
+# says what to do with the value generated by this function, now that
+# it's actually been invoke.
+
+class ApplyCont extends Continuation
+  constructor: (@kont, @fn, @env) ->
+    @_type = "ApplyCont"
+  resume: (value) ->
+    @fn.invoke value, @env, @kont
+
+# A special continuation that represents what we want the interpreter
+# to do when it's done processing.
+
+class BottomCont extends Continuation
+  constructor: (@kont, @func) ->
+    @_type = "BottomCont"
+  resume: (value) ->
+    @func(value)
+  unwind: (value, ktarget) ->
+    throw new LispInterpreterError "Obsolete continuation"
+  catchLookup: (tag, kk) ->
+    throw new LispInterpreterError "No associated catch"
+
+# A block is an implicit begin.  So we evaluate it's contents with a
+# new block-environment, which will automatically unwind any contents
+# found within by traversing up the environment stack looking for
+# labels that match the one with which this block was created.
+
+evaluateBlock = (label, body, env, kont) ->
+  k = new BlockCont(kont, label)
+  evaluateBegin body, (new BlockEnv env, label, k), k
+
+class BlockCont extends Continuation
+  constructor: (@kont, @label) ->
+    @_type = "BlockCont"
+  resume: (value) ->
+    @kont.resume value
+
+class BlockEnv extends FullEnv
+  constructor: (@others, @name, @kont) ->
+  blockLookup: (name, kont, value) ->
+    if (name == @name)
+      kont.unwind value, @kont
+    else
+      @others.blockLookup(name, kont, value)
+
+evaluateReturnFrom = (label, form, env, kont) ->
+  evaluate form, env, (new ReturnFromCont kont, env, label)
+
+# Note that when return-from-cont's body has been evaluated, we then
+# unwind up the environment stack until we find the first block that
+# has the same label and call the continuation saved there.  Note that
+# this is the *first* time that continuation and executable is stored
+# on the environment, and isn't implicitly part of the continuation
+# stack.
+
+class ReturnFromCont extends Continuation
+  constructor: (@kont, @env, @label) ->
+    @_type = "ReturnFromCont"
+  resume: (v) ->
+    @env.blockLookup @label, @kont, v
+
+evaluateCatch = (tag, body, env, kont) ->
+  evaluate tag, env, (new CatchCont kont, body, env)
+
+# catch-continuation receives (from evaluate) the processed value of a
+# tag, the current environment, and what should happen after the
+# context containing the catch is complete (the passed in 'kont' to
+# evaluateCatch).  That processed value becomes the label of the new
+# labeled-continuation.
+
+class CatchCont extends Continuation
+  constructor: (@kont, @body, @env) ->
+    @_type = "CatchFromCont"
+  resume: (value) ->
+    evaluateBegin @body, @env, (new LabeledCont @kont, value)
+
+# Resume here does just that; it just resumes with the continuation
+# passed in above.  But should catch be *triggered* by a throw (and
+# the throw-continuation), we get the contents of throw as an object
+# to be evaluated with its current environment, then continue with
+# *this* as the continuation passed to throwing-continuation, which
+# resumes the catchLookup until the stack is exhausted.
+
+class LabeledCont extends Continuation
+  constructor: (@kont, @tag) ->
+    @_type = "LabeledFromCont"
+  resume: (value) ->
+    @kont.resume value
+  catchLookup: (tag, kk) ->
+    if eq tag, @tag
+      evaluate kk.form, kk.env, (new ThrowingCont kk, tag, this)
+    else
+      @kont.catchLookup tag, kk
+
+class ThrowCont extends Continuation
+  constructor: (@kont, @form, @env) ->
+    @_type = "ThrowCont"
+  resume: (value) ->
+    @catchLookup value, @
+  
+evaluateThrow = (tag, form, env, kont) ->
+  evaluate tag, env, (new ThrowCont kont, form, env)
+
+class UnwindCont extends Continuation
+  constructor: (@kont, @value, @target) ->
+  resume: (value) ->
+    @kont.unwind @value, @target
+
+evaluateUnwindProtect = (form, cleanup, env, kont) ->
+  evaluate form, env, (new UnwindProtectCont kont, cleanup, env)
+
+# If the continuation is "resumed," it works like normal; but if its
+# "unwound," it works its way up the unwind stack looking for the
+# target continuation to which to deliver the value.
+
+class UnwindProtectCont extends Continuation
+  constructor: (@kont, @cleanup, @env) ->
+    @_type = "UnwindProtectCont"
+  resume: (value) ->
+    evaluateBegin @cleanup, @env, (new ProtectReturnCont @kont, value)
+  unwind: (value, target) ->
+    evaluateBegin @cleanup, @env, (new UnwindCont @kont, value, target)
+
+# Works its way through the stack environment stack, looking for
+# ("breaching") protected blocks to unwind, and processing them as
+# necessary.  One of those will by definition be the continuation
+# passed to the catch continuation: the throwing-continuation was
+# constructed with the catch continuation itself as the address of the
+# resumecont.
+
+class ThrowingCont extends Continuation
+  constructor: (@kont, @tag, @resumecont) ->
+    @_type = "ThrowingCont"
+  resume: (value) ->
+    @kont.unwind value, @resumecont
+
+# Note that this behavior basically much like throwing-continuation,
+# except that it's the resumption (the next continuation), rather than
+# the rewind.
+
+class ProtectReturnCont extends Continuation
+  constructor: (@kont, @value) ->
+    @_type = "ProtectReturnCont"
+  resume: (value) ->
+    @kont.resume @value
+
+# The bottom of the function pile, where native code is invoked.
+
+class Primitive extends Value
+  constructor: (@name, @nativ) ->
+    @_type = "Primitive"
+  invoke: (args, env, kont) ->
+    @nativ.apply null, [args, env, kont]
+
+env_init = new NullEnv()
+
+definitial = (name, value = nil) ->
+  env_init = new VariableEnv env_init, name, value
+  name
+
+defprimitive = (name, nativ, arity) ->
+  definitial name, new Primitive name, (args, env, kont) ->
+    vmargs = listToVector(args)
+    if (vmargs.length == arity)
+      # Note that native.apply(ctx, vmargs) is expected to return a
+      # singleton, like all evaluate() passes.
+      kont.resume (nativ.apply null, vmargs)
+    else 
+      throw new LispInterpreterError "Incorrect arity"
+
+defpredicate = (name, nativ, arity) ->
+  defprimitive name, ((a, b) -> if nativ.call(null, a, b) then true else the_false_value), arity
+
+definitial "#t", true
+definitial "#f", the_false_value
+definitial "nil", nil
+
+# FIXME: All of these things dereference to the same value!!!!
+
+for i in [
+  "x", "y", "z", "a", "b", "c", "foo", "bar", "hux",
+  "fib", "fact", "visit", "primes", "length"]
+  definitial i
+
+defprimitive "cons", cons, 2
+defprimitive "car", car, 2
+defprimitive "cdr", cdr, 2
+defprimitive "set-cdr!", setcdr, 2
+defprimitive "set-car!", setcar, 2
+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 "gt", ((a, b) -> a > b), 2
+defpredicate "lte", ((a, b) -> a <= b), 2
+defpredicate "gte", ((a, b) -> a >= b), 2
+defpredicate "eq?", ((a, b) -> a == b), 2
+defpredicate "pair?", ((a) -> pairp a), 1
+defpredicate "nil?", ((a) -> nilp a), 1
+defpredicate "symbol?", ((a) -> /\-?[0-9]+$/.test(a) == false), 1
+
+definitial "call/cc", new Primitive "call/cc", (values, env, kont) ->
+  if nilp cdr values
+    (car values).invoke (cons kont), env, kont
+  else
+    throw new LispInterpreterError "Incorrect arity for call/cc"
+
+definitial "apply", new Primitive "apply", (values, env, kont) ->
+  if pairp cdr values
+    f = car values
+    args = (() ->
+      (flat = (args) ->
+        if nilp (cdr args) then (car args) else (cons (car args), (flat cdr args)))(cdr values))()
+    f.invoke args, env, kont
+
+definitial "funcall", new Primitive "funcall", (args, env, kont) ->
+    if not nilp cdr args
+      kont.invoke (env.lookup (car args)), (cdr args)
+    else
+      throw new LispInterpreterError "Invoke requires a function name and arguments"
+
+definitial "list", new Primitive "list", (values, env, kont) ->
+  (values, env, kont) -> kont.resume(values)
+
+# Only called in rich node mode...
+
+astSymbolsToLispSymbols = (node) ->
+  return nil if nilp node
+  throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
+  handler = (cell) ->
+    return nil if nilp cell
+    cons (car cell).value, (handler cdr cell)
+  handler node.value
+
+metadata_evaluation =
+  listp:     (node) -> node.type == 'list'
+  symbolp:   (node) -> node.type == 'symbol'
+  numberp:   (node) -> node.type == 'number'
+  stringp:   (node) -> node.type == 'string'
+  commentp:  (node) -> node.type == 'comment'
+  nvalu:     (node) -> node.value
+  mksymbols: (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
+
+
+prox = 
+  "quote":   (body, env, kont, ix) -> evaluateQuote (cadr body), env, kont
+  "if":      (body, env, kont, ix) -> evaluateIf (cdr body), env, kont
+  "begin":   (body, env, kont, ix) -> evaluateBegin (cdr body), env, kont
+  "set!":    (body, env, kont, ix) -> evaluateSet (ix.nvalu cadr body), (caddr body), env, kont
+  "lambda":  (body, env, kont, ix) -> evaluateLambda (ix.mksymbols cadr body), (cddr body), env, kont
+  "block":   (body, env, kont, ix) -> evaluateBlock (ix.nvalu cadr body), (cddr body), env, kont
+  "return":  (body, env, kont, ix) -> evaluateReturnFrom (ix.nvalu cadr body), (caddr body), env, kont
+  "catch":   (body, env, kont, ix) -> evaluateCatch (cadr body), (cddr body), env, kont
+  "throw":   (body, env, kont, ix) -> evaluateThrow (cadr body), (caddr body), env, kont
+  "protect": (body, env, kont, ix) -> evaluateUnwindProtect (cadr body), (cddr body), env, kont
+
+makeEvaluator = (ix = straight_evaluation, ty="straight") ->
+  (exp, env, kont) ->
+    if ix.symbolp exp
+      return evaluateVariable (ix.nvalu exp), env, kont
+    else if ([ix.numberp, ix.stringp].filter (i) -> i(exp)).length > 0
+      return kont.resume ix.nvalu exp
+    else if ix.listp exp
+      body = ix.nvalu exp
+      head = car body
+      if ix.symbolp head
+        # Every call is boiled down to body/env/kont (with ix.nvalu tossed in for fun)
+        # It should be possible to move natives into an address space
+        if prox[(ix.nvalu head)]?
+          prox[(ix.nvalu head)](body, env, kont, ix)
+        else evaluateApplication (car body), (cdr body), env, kont
+      else
+        evaluateApplication (car body), (cdr body), env, kont
+    else
+      throw new LispInterpreterError("Can't handle a '#{type}'")
+  
+nodeEval = makeEvaluator(metadata_evaluation, "node")
+lispEval = makeEvaluator(straight_evaluation, "lisp")
+
+evaluate = (exp, env, kont) ->
+  (if exp? and (exp instanceof Node) then nodeEval else lispEval)(exp, env, kont)
+
+interpreter = (ast, kont) ->
+  evaluate ast, env_init, new BottomCont null, kont
+
+module.exports = interpreter

chapter3g/test.coffee

@@ -0,0 +1,12 @@
+olisp = require '../chapter3g/interpreter'
+{read, readForms} = require '../chapter1/reader'
+{inspect} = require 'util'
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+# console.log lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (throw 1 (throw 2 5)) )) )))"
+
+console.log lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0)"

chapter4/interpreter.coffee

@@ -0,0 +1,479 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
+ cadr, caadr, cadar, caddr, nilp, nil, setcdr,
+ metacadr, setcar} = require "cons-lists/lists"
+{length} = require "cons-lists/reduce"
+{normalizeForms, normalizeForm} = require "../chapter1/astToList"
+{Node, Comment, Symbol} = require '../chapter1/reader_types'
+{inspect} = require 'util'
+
+itap = (a) -> return inspect a, true, null, false
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+the_false_value = (cons "false", "boolean")
+
+eq = (id1, id2) ->
+  if id1 instanceof Symbol and id2 instanceof Symbol
+    return id1.name == id2.name
+  id1 == id2
+
+# Only called in rich node mode...
+
+astSymbolsToLispSymbols = (node) ->
+  return nil if nilp node
+  throw (new LispInterpreterError "Not a list of variable names") if not node.type == 'list'
+  handler = (cell) ->
+    return nil if nilp cell
+    cons (car cell).value, (handler cdr cell)
+  handler node.value
+
+cadddr = metacadr('cadddr')
+
+intlistp =     (node) -> node.type == 'list'
+intpairp =     (node) -> node.type == 'list' and ((node.value.length < 2) or node.value[1].node.type != 'list')
+intsymbolp =   (node) -> node.type == 'symbol' or node instanceof Symbol
+intnumberp =   (node) -> node.type == 'number'
+intstringp =   (node) -> node.type == 'string'
+intcommentp =  (node) -> node.type == 'comment'
+intnvalu =     (node) -> node.value
+intatomp =     (node) -> node.type in ['symbol', 'number', 'string']
+intnullp =     (node) -> node.type == 'symbol' and node.value.name == 'null'
+intmksymbols = (list) -> astSymbolsToLispSymbols(list)
+
+# The hairness of this makes me doubt the wisdom of using Javascript.
+
+sBehavior = new Symbol 'behavior'
+sBoolean  = new Symbol 'boolean'
+sBoolify  = new Symbol 'boolify'
+sFunction = new Symbol 'function'
+sSymbol   = new Symbol 'symbol'
+sString   = new Symbol 'string'
+sValue    = new Symbol 'chars'
+sName     = new Symbol 'name'
+sNumber   = new Symbol 'number'
+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 (cadr body), (caddr body), env, mem, kont
+
+#  ___          _           _
+# | __|_ ____ _| |_  _ __ _| |_ ___ _ _
+# | _|\ V / _` | | || / _` |  _/ _ \ '_|
+# |___|\_/\__,_|_|\_,_\__,_|\__\___/_|
+#
+
+transcode = (value, mem, qont) ->
+  forms = [
+    [intnullp, -> qont theEmptyList, mem],
+    [((v) -> intsymbolp(v) and v in ['#t', '#f']), (-> qont (createBoolean value), mem)]
+    [intsymbolp, (-> qont (createSymbol value), mem)]
+    [intnumberp, (-> qont (createNumber value), mem)]
+    [intstringp, (-> qont (createString value), mem)]
+    [intlistp,   (-> transcode (car intnvalu value), mem, (addr, mem2) ->
+      (transcode (cdr intvalu value), mem2, (d, mem3) ->
+        (allocatePair addr, d, mem3, qont)))]
+  ]
+  found = (form[1] for form in forms when form[0](value))
+  if found.length != 1
+    throw new LispInterpreterError "Bad transcode match for #{value}"
+  found[0]()
+
+transcode2 = (value, mem, qont) ->
+  forms = [
+    [((v) -> v instanceof Symbol and v.name == 'null'), (-> qont theEmptyList, mem)],
+    [((v) -> v instanceof Symbol and v.name in ['#t', '#f']), (-> qont (createBoolean value), mem)]
+    [((v) -> v instanceof Symbol), (-> qont (createSymbol value), mem)]
+    [((v) -> typeof v == 'string'), (-> qont (createString value), mem)]
+    [((v) -> typeof v == 'number'), (-> qont (createNumber value), mem)]
+    [((v) -> v.__type == 'list'), (-> transcode (car value), mem, (addr, mem2) ->
+      (transcode (cdr value), mem2, (d, mem3) ->
+        (allocatePair addr, d, mem3, qont)))]
+  ]
+  found = (form[1] for form in forms when form[0](value))
+  if found.length < 1
+    throw new LispInterpreterError "Bad transcode match for #{value}"
+  found[0]()
+
+
+transcodeBack = (value, mem) ->
+  forms = [
+    [sBoolean,  ((v) -> ((v sBoolify) true, false))]
+    [sSymbol,   ((v) -> (v sName))]
+    [sString,   ((v) -> (v sValue))]
+    [sNumber,   ((v) -> (v sValue))]
+    [sPair,     ((v) ->
+      cons (transcodeBack (mem (v sCar)), mem), (transcodeBack (mem (v sCdr)), mem))]
+    [sFunction, (v) -> v]
+  ]
+  found = (form[1] for form in forms when (eq (value sType), form[0]))
+  if found.length != 1
+    throw new LispInterpreterError "Bad transcode-back match for #{value}"
+  found[0](value)
+
+evaluate = (exp, env, mem, kont) ->
+  if intatomp exp
+    if intsymbolp exp
+      evaluateVariable (intnvalu exp), env, mem, kont
+    else
+      evaluateQuote exp, env, mem, kont
+  else
+    body = intnvalu exp
+    head = car body
+    pname = (intnvalu head)
+    if pname instanceof Symbol and prox[pname.name]?
+      prox[pname.name](body, env, mem, kont)
+    else
+      evaluateApplication head, (cdr body), env, mem, kont
+
+env_init = (id) ->
+  throw new LispInterpreterError "No binding for " + id
+
+# This is basically the core definition of 'mem': it returns a
+# function enclosing the address (a monotomically increasing number as
+# memory is allocated) and the value.  Update is passed the current
+# 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)
+
+updates = (mem, addrs, values) ->
+  if (pairp addrs)
+    updates (update mem, (car addrs), (car values)), (cdr addrs), (cdr values)
+  else
+    mem
+
+# 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
+
+evaluateSet = (name, exp, env, mem, kont) ->
+  evaluate exp, env, mem, (value, mem2) ->
+    kont value, (update mem2, (env name), value)
+
+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, mem3) ->
+          kont (cons value, value2), mem3
+    else
+      kont cons(), mem
+
+  evaluate exp, env, mem, (fun, mem2) ->
+    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) ->
+      if eq (length names), (length values)
+        allocate (length names), mem, (addrs, mem2) ->
+          evaluateBegin exprs, (updates env, names, addrs), (updates mem2, addrs, values), kont
+      else
+        throw new LispInterpreterError "Incorrect Arrity"), mem2
+
+evaluateIf = (expc, expt, expf, env, mem, kont) ->
+  evaluate expc, env, mem, (env, mems) ->
+    evaluate ((env sBoolify) expt, expf), env, mems, kont
+
+evaluateQuote = (c, env, mem, kont) ->
+  transcode2 (normalizeForm 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))()
+
+# I like how, in this version, we explicitly throw away the meaning of
+# all but the last statement in evaluateBegin.
+evaluateBegin = (exps, env, mem, kont) ->
+  if pairp (cdr exps)
+    evaluate (car exps), env, mem, (_, mems) ->
+      evaluateBegin (cdr exps), env, mems, kont
+  else
+    evaluate (car exps), env, mem, kont
+
+theEmptyList = (msg) ->
+  switch msg
+    when sType then sNull
+    when sBoolify then (x, y) -> x
+
+createBoolean = (value) ->
+  combinator = if value then ((x, y) -> x) else ((x, y) -> y)
+  (msg) ->
+    switch msg
+      when sType then sBoolean
+      when sBoolify then combinator
+
+createSymbol = (value) ->
+  (msg) ->
+    switch msg
+      when sType then sSymbol
+      when sName then value
+      when sBoolify then (x, y) -> x
+
+createNumber = (value) ->
+  (msg) ->
+    switch msg
+      when sType then sNumber
+      when sValue then value
+      when sBoolify then (x, y) -> x
+
+createString = (value) ->
+  (msg) ->
+    switch msg
+      when sType then sString
+      when sValue then value
+      when sBoolify then (x, y) -> x
+
+createFunction = (tag, behavior) ->
+  (msg) ->
+    switch msg
+      when sType then sFunction
+      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
+      q theEmptyList, mem
+  consify values, q
+
+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) ->
+  if typeof name == 'string'
+    name = new Symbol name
+  allocate 1, mem_global, (addrs, mem2) ->
+    env_global = update env_global, 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
+        throw new LispInterpreterError "Wrong arity for #{name}"
+
+#  ___      _ _   _ _ _         _   _
+# |_ _|_ _ (_) |_(_) (_)_____ _| |_(_)___ _ _
+#  | || ' \| |  _| | | |_ / _` |  _| / _ \ ' \
+# |___|_||_|_|\__|_|_|_/__\__,_|\__|_\___/_||_|
+#
+
+
+defInitial "#t", createBoolean true
+defInitial "#f", 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) sType), 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) sType), 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 "eq?", 2, (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 sPair
+          (((car values) sCar) == ((cadr values) sCar) and
+           ((car values) sCdr) == ((cadr values) sCdr))
+        when sFunction
+          ((car values) sTag) == ((cadr values) sTag)
+        else false
+    else false)
+
+defPrimitive "eqv?", 2, (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) sValue) == ((cadr values) sValue)
+        when sPair
+          (((car values) sCar) == ((cadr values) sCar) and
+           ((car values) sCdr) == ((cadr values) sCdr))
+        when sFunction
+          ((car values) sTag) == ((cadr values) sTag)
+        else false
+    else false)
+
+module.exports = (ast, kont) ->
+  evaluate ast, env_global, mem_global, (value, mem) ->
+    kont (transcodeBack value, mem)

chapter4/reader.coffee

@@ -0,0 +1,204 @@
+{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
+{inspect} = require "util"
+{Node, Comment, Symbol} = require "../chapter1/reader_types"
+
+NEWLINES   = ["\n", "\r", "\x0B", "\x0C"]
+WHITESPACE = [" ", "\t"].concat(NEWLINES)
+
+EOF = new (class Eof)()
+EOO = new (class Eoo)()
+
+class Source
+  constructor: (@inStream) ->
+    @index = 0
+    @max = @inStream.length - 1
+    @line = 0
+    @column = 0
+
+  peek: -> @inStream[@index]
+
+  position: -> [@line, @column]
+
+  next: ->
+    c = @peek()
+    return EOF if @done()
+    @index++
+    [@line, @column] = if @peek() in NEWLINES then [@line + 1, 0] else [@line, @column + 1]
+    c
+
+  done: -> @index > @max
+
+# IO -> IO
+skipWS = (inStream) ->
+  while inStream.peek() in WHITESPACE then inStream.next()
+
+# msg -> (IO -> Node => Error)
+handleError = (message) ->
+  (line, column) -> new Node('error', message, line, column)
+
+# IO -> Node => Comment
+readComment = (inStream) ->
+  [line, column] = inStream.position()
+  r = (while inStream.peek() != "\n" and not inStream.done()
+    inStream.next()).join("")
+  if not inStream.done()
+    inStream.next()
+  new Node 'comment', (new Comment r), line, column
+
+# IO -> (Node => Literal => String) | Error
+readString = (inStream) ->
+  [line, column] = inStream.position()
+  inStream.next()
+  string = until inStream.peek() == '"' or inStream.done()
+    if inStream.peek() == '\\'
+      inStream.next()
+    inStream.next()
+  if inStream.done()
+    return handleError("end of file seen before end of string.")(line, column)
+  inStream.next()
+  new Node 'string', (string.join ''), line, column
+
+# (String) -> (Node => Literal => Number) | Nothing
+readMaybeNumber = (symbol) ->
+  if symbol[0] == '+'
+    return readMaybeNumber symbol.substr(1)
+  if symbol[0] == '-'
+    ret = readMaybeNumber symbol.substr(1)
+    return if ret? then -1 * ret else undefined
+  if symbol.search(/^0x[0-9a-fA-F]+$/) > -1
+    return parseInt(symbol, 16)
+  if symbol.search(/^0[0-9a-fA-F]+$/) > -1
+    return parseInt(symbol, 8)
+  if symbol.search(/^[0-9]+$/) > -1
+    return parseInt(symbol, 10)
+  if symbol.search(/^nil$/) > -1
+    return nil
+  undefined
+
+# (IO, macros) -> (IO, Node => Number | Symbol) | Error
+readSymbol = (inStream, tableKeys) ->
+  [line, column] = inStream.position()
+  symbol = (until (inStream.done() or inStream.peek() in tableKeys or inStream.peek() in WHITESPACE)
+    inStream.next()).join ''
+  number = readMaybeNumber symbol
+  if number?
+    return new Node 'number', number, line, column
+  new Node 'symbol', (new Symbol symbol), line, column
+
+
+# (Delim, TypeName) -> IO -> (IO, node) | Error
+makeReadPair = (delim, type) ->
+  # IO -> (IO, Node) | Error
+  (inStream) ->
+    inStream.next()
+    skipWS inStream
+    [line, column] = inStream.position()
+    if inStream.peek() == delim
+      inStream.next()
+      return new Node type, nil, line, column
+
+    # IO -> (IO, Node) | Error
+    dotted = false
+    readEachPair = (inStream) ->
+      [line, column] = inStream.position()
+      obj = read inStream, true, null, true
+      if inStream.peek() == delim
+        if dotted then return obj
+        return cons obj, nil
+      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 obj.type == 'error'
+      if obj.type == 'symbol' and obj.value == '.'
+        dotted = true
+        return readEachPair inStream
+      cons obj, readEachPair inStream
+
+    ret = new Node type, readEachPair(inStream), line, column
+    inStream.next()
+    ret
+
+# Type -> (IO -> (IO, Node))
+prefixReader = (type) ->
+  # IO -> (IO, Node)
+  (inStream) ->
+    [line, column] = inStream.position()
+    inStream.next()
+    [line1, column1] = inStream.position()
+    obj = read inStream, true, null, true
+    return obj if obj.type == 'error'
+    new Node "list", cons((new Node("symbol", (new 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
+# future revision I can vertically de-integrate these.
+
+readMacros =
+  '"': readString
+  '(': makeReadPair ')', 'list'
+  ')': handleError "Closing paren encountered"
+  '[': makeReadPair ']', 'vector'
+  ']': handleError "Closing bracket encountered"
+  '{': makeReadPair('}', 'record', (res) ->
+    res.length % 2 == 0 and true or mkerr "record key without value")
+  '}': handleError "Closing curly without corresponding opening."
+  "`": prefixReader 'back-quote'
+  "'": prefixReader 'quote'
+  ",": prefixReader 'unquote'
+  ";": readComment
+
+
+# Given a stream, reads from the stream until a single complete lisp
+# object has been found and returns the object
+
+# IO -> Form
+read = (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, inReadMacros = null, keepComments = false) ->
+  inStream = if inStream instanceof Source then inStream else new Source inStream
+  inReadMacros = if InReadMacros? then inReadMacros else readMacros
+  inReadMacroKeys = (i for i of inReadMacros)
+
+  c = inStream.peek()
+
+  # (IO, Char) -> (IO, Node) | Error
+  matcher = (inStream, c) ->
+    if inStream.done()
+      return if recursiveP then handleError('EOF while processing nested object')(inStream) else nil
+    if c in WHITESPACE
+      inStream.next()
+      return nil
+    if c == ';'
+      return readComment(inStream)
+    ret = if c in inReadMacroKeys then inReadMacros[c](inStream) else readSymbol(inStream, inReadMacroKeys)
+    skipWS inStream
+    ret
+
+  while true
+    form = matcher inStream, c
+    skip = (not nilp form) and (form.type == 'comment') and not keepComments
+    break if (not skip and not nilp form) or inStream.done()
+    c = inStream.peek()
+    null
+  form
+
+# readForms assumes that the string provided contains zero or more
+# forms.  As such, it always returns a list of zero or more forms.
+
+# IO -> (Form* | Error)
+readForms = (inStream) ->
+  inStream = if inStream instanceof Source then inStream else new Source inStream
+  return nil if inStream.done()
+
+  # IO -> (FORM*, IO) | Error
+  [line, column] = inStream.position()
+  readEach = (inStream) ->
+    obj = read inStream, true, null, false
+    return nil if (nilp obj)
+    return obj if obj.type == 'error'
+    cons obj, readEach inStream
+
+  obj = readEach inStream
+  if obj.type == 'error' then obj else new Node "list", obj, line, column
+
+exports.read = read
+exports.readForms = readForms
+exports.Node = Node
+exports.Symbol = Symbol

chapter5/interpreter5a.coffee

@@ -0,0 +1,374 @@
+{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
+ cadr, caadr, cadar, caddr, nilp, nil, setcdr,
+ metacadr, setcar} = require "cons-lists/lists"
+{map} = require "cons-lists/reduce"
+{length} = require "cons-lists/reduce"
+{Node, Comment, Symbol} = require '../chapter5/reader_types'
+{inspect} = require 'util'
+
+itap = (a) -> console.log inspect a, true, null, false; a
+ftap = (a) -> console.log Function.prototype.toString.call(a); a
+
+
+class Value
+  vpos = 0
+  constructor: (@v) ->
+    vpos = vpos + 1
+
+inValue = (f) ->
+  new Value(f)
+
+class LispInterpreterError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+the_false_value = (cons "false", "boolean")
+
+eq = (id1, id2) ->
+  if id1 instanceof Symbol and id2 instanceof Symbol
+    return id1.name == id2.name
+  id1 == id2
+
+cadddr = metacadr('cadddr')
+
+# Hack
+gsym = (x) -> if (x instanceof Symbol) then x.name else x
+
+consp = (e) ->
+  ((pairp e) and (typeof (car e) == 'number') and
+  ((car e) > 0) and (pairp cdr e) and (typeof (cadr e) == 'number') and
+  ((cadr e) > 0) and (nilp cddr e))
+
+convert = (exp, store) ->
+  conv = (e) ->
+    if consp e
+      cons (conv (store (car e)).v), (conv (store (cadr e)).v)
+    else
+      if symbolp e then e.name
+      else if stringp e then '"' + e | '"'
+      else 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 ids)
+    extend (lextends fn, (cdr ids), (cdr values)), (car ids), (car values)
+  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) ->
+    aloop = (n, a) ->
+      if (n > 0)
+        loc = loc - 1
+        aloop (n - 1), (cons loc, a)
+      else
+        qont store, a
+    aloop(num, cons()))()
+
+
+listp =     (cell) -> cell.__type == 'list'
+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] == "\""
+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
+
+sBehavior = new Symbol 'behavior'
+sBoolean  = new Symbol 'boolean'
+sBoolify  = new Symbol 'boolify'
+sFunction = new Symbol 'function'
+sSymbol   = new Symbol 'symbol'
+sString   = new Symbol 'string'
+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'
+sCar      = new Symbol 'car'
+sCdr      = new Symbol 'cdr'
+sSetCar   = new Symbol 'setcar'
+sSetCdr   = new Symbol 'setcdr'
+
+ValueToFunction = (e) ->
+  c = e.v
+  if (typeof c == 'function') then c else throw new LispInterpreterError("Not a function: " + Object.toString(c))
+
+ValueToPair = (e) ->
+  c = e.v
+  if pairp c then c else throw new LispInterpreterError("Not a pair: " + Object.toString(c))
+
+ValueToNumber = (e) ->
+  c = parseInt(e.v, 10)
+  if (typeof c == 'number') then c else throw new LispInterpreterError("Not a number: " + Object.toString(c))
+
+ValueToPrimitive = (e) ->
+  return e.v
+
+store_init = (a) -> throw new LispInterpreterError "No such address: #{a}"
+env_init = (a) -> throw new LispInterpreterError "No such variable: #{a}"  
+
+class Interpreter
+  constructor: ->
+    arity_check = (name, arity, fn) =>
+      (values, kont, store) =>
+        if not eq (length values), arity
+          throw new LispInterpreterError "Incorrect Arity for #{name}"
+        fn(values, kont, store)
+
+    @definitial "cons", inValue arity_check "cons", 2, (values, kont, store) =>
+      allocate store, 2, (store, addrs) =>
+        kont (inValue (cons (car addrs), (cadr addrs))), (lextends store, addrs, values)
+  
+    @definitial "car", inValue arity_check "car", 1, (values, kont, store) =>
+      kont (store car @valueToPair (car values)), store
+  
+    @definitial "cdr", inValue arity_check "car", 1, (values, kont, store) =>
+      kont (store cadr @valueToPair (car values)), store
+  
+    @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-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
+    @defarithmetic "*",  ((x, y) -> x * y),  2
+    @defarithmetic "/",  ((x, y) -> x / y),  2
+    @defarithmetic "<",  ((x, y) -> x < y),  2
+    @defarithmetic ">",  ((x, y) -> x > y),  2
+    @defarithmetic "=",  ((x, y) -> x == y), 2
+    @defarithmetic "<=", ((x, y) -> x <= y), 2
+    @defarithmetic ">=", ((x, y) -> x >= y), 2
+    @defarithmetic "%",  ((x, y) -> x % y),  2
+  
+    @definitial "apply", arity_check "apply", 2, inValue (values, kont, store) ->
+      flat = (v) ->
+        if pairp v.v
+          cons (store (car (ValueToPair v))), (flat (store (cadr (ValueToPair v))))
+        else
+          cons()
+
+      collect = (values) ->
+        if nullp cdr values
+          flat car values
+        else
+          cons (car values), (collect cdr values)
+
+      (ValueToFunction (car values)) (collect (cdr values)), kont, store
+
+    @definitial '#t', (inValue true)
+    @definitial '#f', (inValue false)
+    @definitial 'nil', (inValue cons())
+
+    @definitial "x", inValue (new Object(null))
+    @definitial "y", inValue (new Object(null))
+    @definitial "z", inValue (new Object(null))
+    @definitial "a", inValue (new Object(null))
+    @definitial "b", inValue (new Object(null))
+    @definitial "c", inValue (new Object(null))
+    @definitial "foo", inValue (new Object(null))
+    @definitial "bar", inValue (new Object(null))
+    @definitial "hux", inValue (new Object(null))
+    @definitial "fib", inValue (new Object(null))
+    @definitial "fact", inValue (new Object(null))
+    @definitial "visit", inValue (new Object(null))
+    @definitial "length", inValue (new Object(null))
+    @definitial "filter", inValue (new Object(null))
+    @definitial "primes", inValue (new Object(null))
+
+  meaning: (e) ->
+    meaningTable =
+      "quote":  ((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))
+
+    if (atomp e)
+      return if (symbolp e) then (@meaningReference gsym(e)) else (@meaningQuotation e)
+    n = gsym(car e)
+    if meaningTable[n]?
+      meaningTable[n](e)
+    else
+      @meaningApplication (car e), (cdr e)
+
+  meaningSequence: (exps) =>
+    (env, kont, store) =>
+      (@meaningsSequence exps) env, kont, store
+
+  meaningsMultipleSequence: (exp, exps) ->
+    (env, kont, store) =>
+      hkont = (values, store1) =>
+        (@meaningsSequence exps) env, kont, store1
+      (@meaning exp) env, hkont, store
+
+  meaningsSingleSequence: (exp) ->
+    (env, kont, store) =>
+      (@meaning exp) env, kont, store
+
+  meaningsSequence: (exps) ->
+    if not (pairp exps)
+      throw new LispInterpreterError("Illegal Syntax")
+    if pairp cdr exps
+      @meaningsMultipleSequence (car exps), (cdr exps)
+    else
+      @meaningsSingleSequence (car exps)
+
+  meaningQuotation: (val) ->
+    (env, kont, store) ->
+      (translate val, store, kont)
+
+  meaningReference: (name) ->
+    (env, kont, store) ->
+      kont (store (env name)), store
+
+  # Extensional alternative
+
+  meaningAlternative: (exp1, exp2, exp3) ->
+    boolify = (value) ->
+      if (eq? value (inValue false)) then ((x, y) -> y) else ((x, y) -> x)
+
+    ef = (val, val1, val2) ->
+      val val1, val2
+
+    (env, kont, store) =>
+      hkont = (val, store1) =>
+        ef (boolify val), ((@meaning exp2) env, kont, store1), ((@meaning exp3) env, kont, store1)
+      (@meaning exp1)(env, hkont, store)
+
+  # Assignment
+
+  meaningAssignment: (name, exp) ->
+    name = if name instanceof Symbol then name.name else name
+    console.log(name)
+    (env, kont, store) =>
+      hkont = (val, store1) ->
+        kont val, (extend store1, (env name), val)
+      (@meaning exp) env, hkont, store
+
+  # Abstraction (keeps a lambda)
+
+  meaningAbstraction: (names, exps) ->
+    (env, kont, store) =>
+      funcrep = (vals, kont1, store1) =>
+        if not (eq (length vals), (length names))
+          throw new LispInterpreterError("Incorrect Arity.")
+        argnamestostore = (store2, addrs) =>
+          (@meaningsSequence exps) (lextends env, names, addrs), kont1, (lextends store2, addrs, vals)
+        allocate store1, (length names), argnamestostore
+      kont (inValue funcrep), store
+
+  meaningVariable: (name) ->
+    (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))
+
+  meaningApplication: (exp, exps) ->
+    (env, kont, store) =>
+      hkont = (func, store1) =>
+        kont2 = (values, store2) ->
+          (ValueToFunction func) values, kont, store2
+        (@meanings exps) env, kont2, store1
+      (@meaning exp) env, hkont, store
+
+  meanings: (exps) =>
+    meaningSomeArguments = (exp, exps) =>
+      (env, kont, store) =>
+        hkont = (value, store1) =>
+          hkont2 = (values, store2) ->
+            kont (cons value, values), store2
+          (@meanings exps) env, hkont2, store1
+        (@meaning exp) env, hkont, store
+
+    meaningNoArguments = ->
+      (env, kont, store) ->
+        kont (cons()), store
+
+    if pairp exps
+      meaningSomeArguments (car exps), (cdr exps)
+    else
+      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
+      name
+
+  defprimitive: (name, value, arity) ->
+    callable = (values, kont, store) =>
+      if not eq arity, (length values)
+        throw new LispInterpreterError "Incorrect Arity for #{name}"
+      kont (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 (value.apply(null, listToVector(map values, ValueToNumber)))), store
+    @definitial name, (inValue callable)
+
+module.exports = (ast, kont) ->
+  interpreter = new Interpreter()
+  store_current = store_init
+  (interpreter.meaning ast)(env_init,
+    ((value, store_final) -> kont (convert value, store_final)), store_current)
+

chapter5/reader.coffee

@@ -0,0 +1,170 @@
+{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
+{inspect} = require "util"
+{Comment, Symbol} = require "../chapter5/reader_types"
+
+NEWLINES   = ["\n", "\r", "\x0B", "\x0C"]
+WHITESPACE = [" ", "\t"].concat(NEWLINES)
+
+EOF = new (class Eof)()
+EOO = new (class Eoo)()
+
+class ReadError extends Error
+  name: 'LispInterpreterError'
+  constructor: (@message) ->
+
+class Source
+  constructor: (@inStream) ->
+    @index = 0
+    @max = @inStream.length - 1
+    @line = 0
+    @column = 0
+
+  peek: -> @inStream[@index]
+
+  position: -> [@line, @column]
+
+  next: ->
+    c = @peek()
+    return EOF if @done()
+    @index++
+    [@line, @column] = if @peek() in NEWLINES then [@line + 1, 0] else [@line, @column + 1]
+    c
+
+  done: -> @index > @max
+
+# IO -> IO
+skipWS = (inStream) ->
+  while inStream.peek() in WHITESPACE then inStream.next()
+
+readMaybeNumber = (symbol) ->
+  if symbol[0] == '+'
+    return readMaybeNumber symbol.substr(1)
+  if symbol[0] == '-'
+    ret = readMaybeNumber symbol.substr(1)
+    return if ret? then -1 * ret else undefined
+  if symbol.search(/^0x[0-9a-fA-F]+$/) > -1
+    return parseInt(symbol, 16)
+  if symbol.search(/^0[0-9a-fA-F]+$/) > -1
+    return parseInt(symbol, 8)
+  if symbol.search(/^[0-9]+$/) > -1
+    return parseInt(symbol, 10)
+  if symbol.search(/^nil$/) > -1
+    return nil
+  undefined
+
+# (Delim, TypeName) -> IO -> (IO, Node) | Errorfor
+makeReadPair = (delim, type) ->
+  # IO -> (IO, Node) | Error
+  (inStream) ->
+    inStream.next()
+    skipWS inStream
+    if inStream.peek() == delim
+      inStream.next() unless inStream.done()
+      return if type then cons((new Symbol type), nil) else nil
+
+    # IO -> (IO, Node) | Error
+    dotted = false
+    readEachPair = (inStream) =>
+      obj = @read inStream, true, null, true
+      if inStream.peek() == delim
+        if dotted then return obj
+        return cons obj, nil
+      return obj if obj instanceof ReadError
+      if inStream.done() then return new ReadError "Unexpected end of input"
+      if dotted then return new ReadError "More than one symbol after dot in list"
+      if @acc(obj) instanceof Symbol and @acc(obj).name == '.'
+        dotted = true
+        return readEachPair inStream
+      cons obj, readEachPair inStream
+
+    obj = readEachPair(inStream)
+    inStream.next()
+    if type then cons((new Symbol type), obj) else obj
+
+# Type -> IO -> IO, Node
+
+class Reader
+  prefixReader = (type) ->
+    # IO -> IO, Node
+    (inStream) ->
+      inStream.next()
+      obj = @read inStream, true, null, true
+      return obj if obj instanceof ReadError
+      list((new Symbol type), obj)
+
+  "acc": (obj) -> obj
+
+  "symbol": (inStream) ->
+    symbol = (until (inStream.done() or @[inStream.peek()]? or inStream.peek() in WHITESPACE)
+      inStream.next()).join ''
+    number = readMaybeNumber symbol
+    if number?
+      return number
+    new Symbol symbol
+
+  "read": (inStream, eofErrorP = false, eofError = EOF, recursiveP = false, keepComments = false) ->
+    inStream = if inStream instanceof Source then inStream else new Source inStream
+
+    c = inStream.peek()
+
+    # (IO, Char) -> (IO, Node) | Error
+    matcher = (inStream, c) =>
+      if inStream.done()
+        return if recursiveP then (new ReadError 'EOF while processing nested object') else nil
+      if c in WHITESPACE
+        inStream.next()
+        return nil
+      if c == ';'
+        return readComment(inStream)
+      ret = if @[c]? then @[c](inStream) else @symbol(inStream)
+      skipWS inStream
+      ret
+
+    while true
+      form = matcher inStream, c
+      skip = (not nilp form) and (form instanceof Comment) and not keepComments
+      break if (not skip and not nilp form) or inStream.done()
+      c = inStream.peek()
+      null
+    form
+
+  '(': makeReadPair ')', null
+
+  '[': makeReadPair ']', 'vector'
+
+  '{': makeReadPair('}', 'record', (res) ->
+    res.length % 2 == 0 and true or mkerr "record key without value")
+
+  '"': (inStream) ->
+    inStream.next()
+    s = until inStream.peek() == '"' or inStream.done()
+      if inStream.peek() == '\\'
+        inStream.next()
+      inStream.next()
+    return (new ReadError "end of file seen before end of string") if inStream.done()
+    inStream.next()
+    s.join ''
+
+  ')': (inStream) -> new ReadError "Closing paren encountered"
+
+  ']': (inStream) -> new ReadError "Closing bracket encountered"
+
+  '}': (inStream) -> new ReadError "Closing curly without corresponding opening."
+
+  "`": prefixReader 'back-quote'
+
+  "'": prefixReader 'quote'
+
+  ",": prefixReader 'unquote'
+
+  ";": (inStream) ->
+    r = (while inStream.peek() != "\n" and not inStream.done()
+      inStream.next()).join("")
+    inStream.next() if not inStream.done()
+    new Comment r
+
+exports.Source = Source
+exports.ReadError = ReadError
+exports.Reader = Reader
+reader = new Reader()
+exports.read = -> reader.read.apply(reader, arguments)

chapter5/reader_rawtoform.coffee

@@ -0,0 +1,39 @@
+{car, cdr, cons, listp, nilp, nil,
+ list, pairp, listToString} = require 'cons-lists/lists'
+
+{Symbol, Comment} = require './reader_types'
+
+class Normalize
+  normalize: (form) ->
+    return nil if nilp form
+
+    if (pairp form)
+      if (car form) instanceof Symbol and (car form).name in ['vector', 'record']
+        @[(car form).name](cdr form)
+      else
+        @list form
+    else
+      form
+
+  list: (form) ->
+    handle = (form) =>
+      return nil if nilp form
+      if not pairp form
+        return @normalize form
+      cons (@normalize car form), (handle cdr form)
+    handle form
+
+  vector: (form) ->
+    until (nilp form) then p = @normalize(car form); form = cdr form; p
+
+  record: (form) ->
+    o = Object.create(null)
+    until (nilp form)
+      o[(@normalize car form)] = (@normalize car cdr form)
+      form = cdr cdr form
+      null
+    o
+
+exports.Normalize = Normalize
+normalize = new Normalize()
+exports.normalize = -> normalize.normalize.apply(normalize, arguments)

chapter5/reader_tracktoform.coffee

@@ -0,0 +1,14 @@
+{Node} = require './reader_types'
+{Normalize} = require './reader_rawtoform'
+
+liftToNode = (f) ->
+  (form) ->
+    return f.call this, (if (form instanceof Node) then form.v else form)
+
+NodeNormalize = class
+for own key, func of Normalize::
+  NodeNormalize::[key] = liftToNode(func)
+
+exports.Normalize = NodeNormalize
+normalize = new NodeNormalize()
+exports.normalize = -> normalize.normalize.apply(normalize, arguments)

chapter5/reader_types.coffee

@@ -0,0 +1,11 @@
+exports.Node = class
+  constructor: (@v, @line, @column) ->
+
+exports.Symbol = class
+  constructor: (@name) ->
+    
+exports.Comment = class
+  constructor: (@text) ->
+
+
+          

chapter5/tracking_reader.coffee

@@ -0,0 +1,25 @@
+{Reader, ReadError, Source} = require './reader'
+{Node} = require './reader_types'
+
+liftToTrack = (f) ->
+  (ioStream) ->
+    ioStream = if ioStream instanceof Source then ioStream else new Source ioStream
+    [line, column] = ioStream.position()
+    obj = f.apply(this, arguments)
+    if obj instanceof ReadError
+      obj['line'] = line
+      obj['column'] = column
+      return obj
+    if obj instanceof Node then obj else new Node obj, line, column
+
+TrackingReader = class
+
+for own key, func of Reader::
+  TrackingReader::[key] = liftToTrack(func)
+TrackingReader::acc = (obj) -> obj.v
+
+exports.ReadError = ReadError
+exports.Reader = TrackingReader
+exports.reader = reader = new TrackingReader()
+exports.read = -> reader.read.apply(reader, arguments)
+

coffeelint.json

@@ -0,0 +1,129 @@
+{
+  "arrow_spacing": {
+    "level": "ignore"
+  },
+  "braces_spacing": {
+    "level": "ignore",
+    "spaces": 0,
+    "empty_object_spaces": 0
+  },
+  "camel_case_classes": {
+    "level": "error"
+  },
+  "coffeescript_error": {
+    "level": "error"
+  },
+  "colon_assignment_spacing": {
+    "level": "ignore",
+    "spacing": {
+      "left": 0,
+      "right": 0
+    }
+  },
+  "cyclomatic_complexity": {
+    "value": 10,
+    "level": "ignore"
+  },
+  "duplicate_key": {
+    "level": "error"
+  },
+  "empty_constructor_needs_parens": {
+    "level": "ignore"
+  },
+  "ensure_comprehensions": {
+    "level": "warn"
+  },
+  "eol_last": {
+    "level": "ignore"
+  },
+  "indentation": {
+    "value": 2,
+    "level": "error"
+  },
+  "line_endings": {
+    "level": "ignore",
+    "value": "unix"
+  },
+  "max_line_length": {
+    "value": 120,
+    "level": "error",
+    "limitComments": true
+  },
+  "missing_fat_arrows": {
+    "level": "ignore",
+    "is_strict": false
+  },
+  "newlines_after_classes": {
+    "value": 3,
+    "level": "ignore"
+  },
+  "no_backticks": {
+    "level": "error"
+  },
+  "no_debugger": {
+    "level": "warn",
+    "console": false
+  },
+  "no_empty_functions": {
+    "level": "ignore"
+  },
+  "no_empty_param_list": {
+    "level": "ignore"
+  },
+  "no_implicit_braces": {
+    "level": "ignore",
+    "strict": true
+  },
+  "no_implicit_parens": {
+    "strict": true,
+    "level": "ignore"
+  },
+  "no_interpolation_in_single_quotes": {
+    "level": "ignore"
+  },
+  "no_plusplus": {
+    "level": "ignore"
+  },
+  "no_stand_alone_at": {
+    "level": "ignore"
+  },
+  "no_tabs": {
+    "level": "error"
+  },
+  "no_this": {
+    "level": "ignore"
+  },
+  "no_throwing_strings": {
+    "level": "error"
+  },
+  "no_trailing_semicolons": {
+    "level": "error"
+  },
+  "no_trailing_whitespace": {
+    "level": "error",
+    "allowed_in_comments": false,
+    "allowed_in_empty_lines": true
+  },
+  "no_unnecessary_double_quotes": {
+    "level": "ignore"
+  },
+  "no_unnecessary_fat_arrows": {
+    "level": "warn"
+  },
+  "non_empty_constructor_needs_parens": {
+    "level": "ignore"
+  },
+  "prefer_english_operator": {
+    "level": "ignore",
+    "doubleNotLevel": "ignore"
+  },
+  "space_operators": {
+    "level": "ignore"
+  },
+  "spacing_after_comma": {
+    "level": "ignore"
+  },
+  "transform_messes_up_line_numbers": {
+    "level": "warn"
+  }
+}

docs/20150607.md

@@ -0,0 +1,67 @@
+I've been working my way through a Lisp textbook, *Lisp In Small
+Pieces*, by Christian Quinnec.  It was originally written in French and
+is not that well known among English-speaking Lisperati, not in
+comparison to the Wizard book or Paul Graham's *On Lisp*, but what
+caught my attention was how it really was in *small* pieces.  Each
+chapter ended with an interpreter described, sometimes in code,
+sometimes in text; if you were smart enough, you could actually piece
+the whole thing together and see how it worked.
+
+I decided to make things hard for myself.  Since I'm *not* a Lisperati
+(although I may well and truly be seduced by Hy), I decided to make
+things hard for myself by writing the interpreter in Coffeescript.  Most
+Lisp books assume you have a Lisp handy, and Quinnec's examples are fine
+and dandy on many variants of Scheme, but for a fun time I decided to
+write it in something else.  Raganwald claims Javascript "is a Lisp,"
+and if that's so it ought to be good enough to write a Lisp in it.
+
+I mean, it's obviously been done before.  I tried once before but got
+lost.  *LiSP* does me the favor of keeping me on track.
+
+You can see all my sourcecode at <a
+href="https://github.com/elfsternberg/LispInSmallPieces">Github: Lisp In
+Small Pieces</a>.
+
+Chapter 1 contains the base interpreter.  It also contains a
+hand-written Lisp reader, and refers to another project I have on
+GitHub, <a
+href="https://github.com/elfsternberg/cons-lists">cons-lists</a>, which
+is exactly what it sounds like, a singly-linked list implementation in
+Javascript, using nested Javascript arrays as the base.  The base
+interpreter is very primitive-- you can't even create new variable names
+in the global namespace!  Although you can shadow them using lambdas, so
+it's pretty much bog standard Lambda Calculus.
+
+Chapter "Lambda 1" contains a continuation-passing variant of the
+interpreter from Chapter 1.  It's basically a facile reading of
+Lisperator's λ-language intepreter, with my own parser front-end and
+some CPS style.  It passes all the tests, but it's a distraction.
+
+Chapter 3 contains the same interpreter, only using the architecture
+Quinnec describes in Chapter 3 of his book.
+
+Chapter 2 describes a number of different methodologies for binding,
+scoping, and namespaces.  The material is interesting but I didn't
+pursue writing the various interpreters.  I "got" what Quinnec was
+saying, and if I'm ever interested in writing something with scoping
+rules outside of the lexical scopes with which I'm familiar, I might
+revisit the material.
+
+The next step will be to add functions to the Chapter 3 interpreter to
+do the various continuation management games, like call/cc, throw/catch,
+$and so forth.  Because *those*, I feel I need to understand.
+
+How far will I take this project?  I’m not sure.  Chapter 4 is
+"Assignment and Side Effects," so I’ll do that.  Chapter 5 is theory,
+and 6 implementation, of a "fast interpreter" of the kind French
+programming language guys apparently love to study.  I’ll read them, but
+I’m not sure what code I’ll generate out of that.  Chapter 7,
+"Compilation," is interesting in that he starts by defining a VM that on
+top of which our bytecode will run, and implement both the VM and the
+compiler in Scheme.  I think I want to do that chapter, and then
+re-write the compiler to create LLVM-compatible code instead, just to
+learn LLVM.  Chapter 8 implements EVAL, chapter 9 has Macros, and
+chapter 10 has Object-Oriented Lisp.  So I’ll probably do those as well.
+
+And then... we’ll see.  I surprised myself by doing Chapter 3 in less
+than two weeks.

docs/new.md

@@ -0,0 +1,12 @@
+This doesn't really look like the read/analyze/compile passes that one
+expects of a modern Lisp.
+
+Reading converts the source code into a list of immutable values in the
+low-level AST of the system.  Reading and analysis must be combined if
+there are to be reader macros (which I want to support).
+
+... and then a miracle occurs ...
+
+Compilation is the process of turning the AST into javascript.
+
+

extras/jenkins_config.xml

@@ -0,0 +1,57 @@
+<?xml version='1.0' encoding='UTF-8'?>
+<project>
+  <actions/>
+  <description>Building in the chapters of Lisp In Small Pieces.</description>
+  <logRotator class="hudson.tasks.LogRotator">
+    <daysToKeep>-1</daysToKeep>
+    <numToKeep>10</numToKeep>
+    <artifactDaysToKeep>-1</artifactDaysToKeep>
+    <artifactNumToKeep>-1</artifactNumToKeep>
+  </logRotator>
+  <keepDependencies>false</keepDependencies>
+  <properties/>
+  <scm class="hudson.plugins.git.GitSCM" plugin="git@2.3.4">
+    <configVersion>2</configVersion>
+    <userRemoteConfigs>
+      <hudson.plugins.git.UserRemoteConfig>
+        <url>file:///home/elf/Projects/LispInSmallPieces</url>
+      </hudson.plugins.git.UserRemoteConfig>
+    </userRemoteConfigs>
+    <branches>
+      <hudson.plugins.git.BranchSpec>
+        <name>*/master</name>
+      </hudson.plugins.git.BranchSpec>
+    </branches>
+    <doGenerateSubmoduleConfigurations>false</doGenerateSubmoduleConfigurations>
+    <submoduleCfg class="list"/>
+    <extensions/>
+  </scm>
+  <canRoam>true</canRoam>
+  <disabled>false</disabled>
+  <blockBuildWhenDownstreamBuilding>false</blockBuildWhenDownstreamBuilding>
+  <blockBuildWhenUpstreamBuilding>false</blockBuildWhenUpstreamBuilding>
+  <triggers>
+    <org.jenkinsci.plugins.fstrigger.triggers.FolderContentTrigger plugin="fstrigger@0.39">
+      <spec></spec>
+      <path>file:///home/elf/Projects/LispInSmallPieces</path>
+      <excludeCheckLastModificationDate>false</excludeCheckLastModificationDate>
+      <excludeCheckContent>false</excludeCheckContent>
+      <excludeCheckFewerOrMoreFiles>false</excludeCheckFewerOrMoreFiles>
+    </org.jenkinsci.plugins.fstrigger.triggers.FolderContentTrigger>
+  </triggers>
+  <concurrentBuild>false</concurrentBuild>
+  <builders>
+    <hudson.tasks.Shell>
+      <command>make node_modules test</command>
+    </hudson.tasks.Shell>
+  </builders>
+  <publishers>
+    <hudson.tasks.junit.JUnitResultArchiver plugin="junit@1.2-beta-4">
+      <testResults>test-reports.xml</testResults>
+      <keepLongStdio>false</keepLongStdio>
+      <testDataPublishers/>
+      <healthScaleFactor>1.0</healthScaleFactor>
+    </hudson.tasks.junit.JUnitResultArchiver>
+  </publishers>
+  <buildWrappers/>
+</project>

package.json

@@ -1,5 +1,5 @@
 {
-  "name": "CoffeeLisp",
+  "name": "LispInSmallPieces",
   "version": "0.0.1",
   "description": "A Coffeescript rendition of Lisp In Small Pieces",
   "main": "bin/lisp",
@@ -8,13 +8,21 @@
     "cons-lists": "git+https://github.com/elfsternberg/cons-lists.git"
   },
   "devDependencies": {
+    "coffeelint": "~1.10.0",
     "chai": "^2.0.0",
-    "mocha": "^2.1.0"
+    "mocha": "^2.1.0",
+    "mocha-jenkins-reporter": "^0.1.7"
   },
   "scripts": {
-    "test": "echo \"Error: no test specified\" && exit 1"
+    "test": "make test",
+    "build": "make node_modules"
+  },
+  "repository": {
+    "type": "git",
+    "url": "ssh://elfsternberg@elfsternberg.com/home/elfsternberg/repos/LispInSmallPieces"
   },
   "keywords": [
+    "lisp",
     "scheme",
     "practice",
     "interpreter",

racket/chap1.rkt

@@ -1,192 +0,0 @@
-; Lisp In Small Pieces, chapter 1 Simple Lambda Calculus interpreter
-; with global environment, simple lexical closures enforced by singly
-; linked lists.
-
-; This covers only severals exercise: I added 'exit as an exit value;
-; I fixed the definition of '<', and then applied the exercise out of 
-; the book.
-
-; Any of the exercises that needed call/cc I've avoided for the simple
-; reason that I started this to learn lisp, I'm a raw beginner, and 
-; call/cc is definitely advance estorics.
-
-; Needed for 'wrong-syntax', which is Racket's version of the "wrong"
-; exception tosser.
-
-(require racket/syntax)
-
-; LISP requires a mutatable environment, so using mcons/mpair for
-; that.
-
-(require scheme/mpair)
-
-; Weird; racket needs this as a patch.  I would have expected it as
-; present in the default list of functions!
-
-(define (atom? x)
-  (and (not (null? x))
-       (not (pair? x))))
-
-(define env_init '())
-
-(define env_global env_init)
-
-; So, this macro places *into the current scope* (i.e. no building of
-; a new scope that gets reaped upon exit) the names of variables and
-; potential initial values.
-
-(define-syntax definitial
-  (syntax-rules ()
-    ((definitial name)
-     (begin (set! env_global (mcons (mcons 'name 'void) env_global)) 'name))
-    ((definitial name value)
-     (begin (set! env_global (mcons (mcons 'name value) env_global)) 'name))))
-
-; Oh! This macro (same scope thing again) associates named things with
-; values in the target environment (the host language), along with
-; arity checking.  (which it doesn't do for 'if', for example)
-
-(define-syntax defprimitive
-  (syntax-rules ()
-    ((defprimitive name value arity)
-     (definitial name 
-       (lambda (values)
-         (if (= arity (length values))
-             (apply value values)
-             (wrong-syntax #'here "Incorrect arity ~s" (list 'name values))))))))
-
-; Sometimes, you do have to define something before you use it. Lesson
-; learned.
-
-(define the-false-value (cons "false" "boolean"))
-
-(definitial t #t)
-(definitial f the-false-value)
-(definitial nil '())
-(definitial foo)
-(definitial bar)
-(definitial fib)
-(definitial fact)
-
-(define-syntax defpredicate
-  (syntax-rules ()
-    ((_ name native arity)
-     (defprimitive name (lambda args (or (apply native args) the-false-value)) arity))))
-
-(defprimitive cons cons 2)
-(defprimitive car car 1)
-(defprimitive set-cdr! set-mcdr! 2)
-(defprimitive + + 2)
-(defprimitive - - 2)
-(defprimitive * * 2)
-(defpredicate lt < 2)
-(defpredicate eq? eq? 2)
-
-; This function extends the environment so that *at this moment of
-; extension* the conslist head points to the old environment, then
-; when it's done it points to the new environment.  What's interesting
-; is that the conslist head points to the last object initialized, not
-; the first.
-
-(define (extend env variables values) 
-  (cond ((pair? variables)
-         (if (pair? values) 
-             (mcons (mcons (car variables) (car values))
-                    (extend env (cdr variables) (cdr values)))
-             (wrong-syntax #'here "Too few values")))
-        ((null? variables)
-         (if (null? values) 
-             env 
-             (wrong-syntax #'here "Too many values")))
-        ((symbol? variables) (mcons (mcons variables values) env))))
-                         
-; Already we're starting to get some scope here.  Note that
-; make-function provides the environment, not the invoke.  This makes
-; this a lexically scoped interpreter.
-
-(define (make-function variables body env) 
-  (lambda (values) 
-    (eprogn body (extend env variables values))))
-
-; if it's a function, invoke it.  Wow. Much complex. Very interpret.
-
-(define (invoke fn args) 
-  (if (procedure? fn)
-      (fn args)
-      (wrong-syntax #'here "Not an function ~s" fn)))
-
-; Iterate through the exps, return the value of the last one.
-
-(define (eprogn  exps env)
-  (if (pair? exps)
-      (if (pair? (cdr exps))
-          (begin (evaluate (car exps) env)
-                 (eprogn (cdr exps) env))
-          (evaluate (car exps) env))
-      '()))
-  
-; Iterate through the exps, return a list of the values of the
-; evaluated expressions
-
-(define (evlis exps env)
-  (if (pair? exps) 
-      (cons (evaluate (car exps) env)
-            (evlis (cdr exps) env))
-      '()))
-
-; silly patch because of the mutatable lists
-
-(define-syntax mcaar (syntax-rules () ((_ e) (mcar (mcar e)))))
-(define-syntax mcdar (syntax-rules () ((_ e) (mcdr (mcar e)))))
-
-; Iterate through the environment, find an ID, return its associated
-; value.
-
-(define (lookup id env)
-  (if (mpair? env)
-      (if (eq? (mcaar env) id)
-          (mcdar env)
-          (lookup id (mcdr env)))
-      (wrong-syntax #'here "No such binding ~s" id)))
-
-; Iterate through the environment, find an ID, and change its value to
-; the new value.  Again, purely global environment.  Really starting
-; to grok how the environment "stack" empowers modern runtimes.
-
-(define (update! id env value)
-  (if (mpair? env)
-      (if (eq? (mcaar env) id)
-          (begin (set-mcdr! (mcar env) value) value)
-          (update! id (mcdr env) value))
-      (wrong-syntax #'here "No such binding ~s" id)))
-
-; Core evaluation rules.
-
-(define (evaluate exp env)
-  (if (atom? exp)
-      (cond 
-       ((symbol? exp) (lookup exp env))
-       ((or (number? exp) (string? exp) (char? exp) (boolean? exp) (vector? exp)) exp)
-       (else (wrong-syntax #'here "Cannot evaluate")))
-      (case (car exp)
-        ((quote) (cadr exp))
-        ; Note: No checks that the statement even vaguely resembles the rules.
-        ((if) (if (not (eq? (evaluate (cadr exp) env) the-false-value))
-                  (evaluate (caddr exp) env)
-                  (evaluate (cadddr exp) env)))
-        ((begin) (eprogn (cdr exp) env))
-        ((set!) (update! (cadr exp) env (evaluate (caddr exp) env)))
-        ((lambda) (make-function (cadr exp) (cddr exp) env))
-        (else (invoke (evaluate (car exp) env) (evlis (cdr exp) env))))))
-
-; Run it.  Note that the function toplevel is self-referential.
-
-(define (chapter1-scheme)
-  (define (toplevel)
-    (let ((result (evaluate (read) env_global)))
-      (if (not (eq? result 'exit))
-          (begin (display result) (toplevel))
-          #f)))
-  (toplevel))
-
-; (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1))))))

racket/chap3.rkt

@@ -1,10 +0,0 @@
-(define (find-symbol id tree)
-  (call/cc
-   (lambda (exit) 
-     (define (find tree)
-       (if (pair? tree)
-           (or (find (car tree)) (find (cdr tree)))
-           (if (eq? tree id) (exit #t) #f)))
-     (find tree))))
-           
-       

src/eval.coffee

@@ -1,17 +0,0 @@
-lookup = require './lookup'
-{car, cdr, cadr, caadr, cdadr} = require './lists'
-
-lispeval = (element, scope) ->
-
-  switch (car element)
-    when 'number' then parseInt (cadr element), 10
-    when 'string' then (cadr element)
-    when 'symbol' then lookup scope, (cadr element)
-    when 'list'
-      proc = lispeval (caadr element), scope
-      args = cdadr element
-      proc args, scope
-    else throw new Error ("Unrecognized type in parse: #{(car element)}")
-
-module.exports = lispeval
-

src/fn.coffee

@@ -1,43 +0,0 @@
-lispeval = require './eval'
-{cons, nil, nilp, car, cdr, listToVector} = require './lists'
-
-module.exports = 
-  create_vm_expression_evaluator: (defining_scope, params, body) ->
-    (cells, scope) ->
-      args = (amap = (cells, accum) ->
-        return accum if nilp cells
-        amap((cdr cells), accum.concat(lispeval (car cells), scope)))(cells, [])
-      body.apply null, args
-
-  create_lisp_expression_evaluator: (defining_scope, params, body) ->
-    (cells, scope) ->
-
-      # Takes the current scope, which has been passed in during the
-      # execution phase, and evaluate the contents of the parameters
-      # in the context in which this call is made (i.e. when the
-      # function is *called*, rather than defined.
-
-      new_scope = (cmap = (cells, params, nscope) ->
-        return nscope if (nilp cells) or (nilp params)
-        nscope[(car params)] = lispeval (car cells), scope
-        cmap((cdr cells), (cdr params), nscope))(cells, params, {})
-
-      # Execute and evaluate the body, creating an inner scope that
-      # consists of: (1) the bound variables (the parameters)
-      # evaluated in the context of the function call, because that's
-      # where they were encountered (2) the free variables evaluated
-      # in the context of the defining scope, because that's where
-      # *they* were encountered.
-      #
-      # While this inspiration comes from Coglan, the clearest
-      # explanation is from Lisperator's 'make_lambda' paragraph at
-      # http://lisperator.net/pltut/eval1/
-
-      inner_scope = cons(new_scope, defining_scope)
-      (nval = (body, memo) ->
-        return memo if nilp body
-        nval((cdr body), lispeval((car body), inner_scope)))(body)
-
-  create_special_form_evaluator: (defining_scope, params, body) ->
-    (cells, scope) -> body(cells, scope)
-

src/lisp_ch1.coffee

@@ -1,152 +0,0 @@
-{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
-readline = require "readline"
-{inspect} = require "util"
-print = require "./print"
-
-
-env_init = nil
-env_global = env_init
-
-ntype = (node) -> car node
-nvalu = (node) -> cadr node
-
-definitial = (name, value = nil) ->
-  env_global = (cons (cons name, value), env_global)
-  name
-
-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"
-
-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 "+", ((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
-
-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
-
-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 "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.
-
-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 Error("Can't handle a #{type}")
-
-module.exports = (c) -> evaluate c, env_global

src/print.coffee

@@ -1,21 +0,0 @@
-{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar, cadr, caadr, cadar, caddr, nilp, nil, setcdr, metacadr} = require "cons-lists/lists"
-
-ntype = (node) -> car node
-nvalu = (node) -> cadr node
-
-evlis = (exps, d) ->
-  if (pairp exps) then evaluate((car exps), d) + " " + evlis((cdr exps), d) else ""
-
-indent = (d) ->
-  ([0..d].map () -> " ").join('')
-    
-evaluate = (e, d = 0) ->
-  [type, exp] = [(ntype e), (nvalu e)]
-  if type == "symbol" then exp
-  else if type in ["number", "boolean"] then exp
-  else if type == "string" then '"' + exp + '"'
-  else if type == "list" then "\n" + indent(d) + "(" + evlis(exp, d + 2) + ")"
-  else throw "Don't recognize a #{type}"
-    
-module.exports = (c) -> evaluate c, 0
-  

src/scope.coffee

@@ -1,31 +0,0 @@
-lispeval = require './eval'
-{cons, car, cdr, nilp, nil, cadar, cadr, caddr} = require './lists'
-{create_lisp_expression_evaluator, create_vm_expression_evaluator, create_special_form_evaluator} = require './fn'
-
-scope = cons
-  '+': create_vm_expression_evaluator scope, [], (a, b) -> a + b
-  '-': create_vm_expression_evaluator scope, [], (a, b) -> a - b
-  '*': create_vm_expression_evaluator scope, [], (a, b) -> a * b
-  '/': create_vm_expression_evaluator scope, [], (a, b) -> a / b
-  '==': create_vm_expression_evaluator scope, [], (a, b) -> a == b
-  '#t': true
-  '#f': false
-
-  'define': create_special_form_evaluator scope, [], (nodes, scope) ->
-    current = (car scope)
-    current[(cadar nodes)] = lispeval((cadr nodes), scope)
-
-  'lambda': create_special_form_evaluator scope, [], (nodes, scope) ->
-    param_nodes = cadar nodes
-    reducer = (l) ->
-      if (nilp l) then nil else cons (cadar l), reducer(cdr l)
-    param_names = reducer(param_nodes)
-    create_lisp_expression_evaluator scope, param_names, (cdr nodes)
-        
-  'if': create_special_form_evaluator scope, [], (nodes, scope) ->
-    if lispeval (car nodes), scope
-      lispeval (cadr nodes), scope
-    else
-      lispeval (caddr nodes), scope
-
-module.exports = scope

src/test_chap1.coffee

@@ -1,13 +0,0 @@
-lisp = require './lisp_ch1'
-{read, readForms} = require './reader'
-{inspect} = require 'util'
-ast = read("(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))")
-
-# ast = read("(begin (if (lt 4 2) (+ 4 1)  (+ 2 1)))")
-# ast = read("(begin (set! fact 4) fact)")
-# ast = read("(begin ((lambda (t) (if (lt t 2) (+ 4 1)  (+ 2 1))) 1))")
-
-# ast = read("(begin (set! fact (lambda (x) (+ x x))) (fact 5))")
-# ast = read("(begin (set! fact (lambda (x) (- x 4))) (fact 5))")
-
-console.log "Result:",  (lisp ast)

test/reader5_samples.coffee

@@ -0,0 +1,25 @@
+{cons, nil} = require "cons-lists/lists"
+exports.samples = [
+  ['nil', nil]
+  ['0', 0]
+  ['1', 1]
+  ['500', 500]
+  ['0xdeadbeef', 3735928559]
+  ['"Foo"', 'Foo']
+  ['(1)', cons(1)]
+  ['(1 2)', cons(1, (cons 2))]
+  ['(1 2 )', cons(1, (cons 2))]
+  ['( 1 2 )', cons(1, (cons 2))]
+  ['(1 (2 3) 4)', cons(1, cons(cons(2, cons(3)), cons(4)))]
+  ['(   1   2   )', cons(1, (cons 2))]
+  ['("a" "b")', cons("a", (cons "b"))]
+  ['("a" . "b")', cons("a", "b")]
+  ['[]', []]
+  ['{}', {}]
+  ['{"a" [1 2 3] "b" {"c" "d"} "c" ("a" "b" . "c")}', {"a": [1,2,3], "b":{"c": "d"}, "c": cons("a", cons("b", "c"))}]
+  ['[1 2 3]', [1, 2, 3]]
+  ['[1 2 [3 4] 5]', [1, 2, [3, 4], 5]]
+  # ['(1 2 3', 'error']
+  ['{"foo" "bar"}', {foo: "bar"}]
+]
+

test/test_chapter-lambda-1.coffee

@@ -0,0 +1,54 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+olisp = require '../chapter-lambda-1/interpreter'
+{read, readForms} = require '../chapter1/reader'
+
+the_false_value = (cons "false", "boolean")
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+
+describe "Core interpreter #3", ->
+  it "Should handle true statements", ->
+    expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
+  it "Should handle false statements", ->
+    expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
+  it "Should handle return strings", ->
+    expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
+  it "Should handle return strings when false", ->
+    expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
+  it "Should handle equivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
+  it "Should handle inequivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
+
+  it "Should handle basic arithmetic", ->
+    expect(lisp read '(begin (+ 5 5))').to.equal(10)
+    expect(lisp read '(begin (* 5 5))').to.equal(25)
+    expect(lisp read '(begin (/ 5 5))').to.equal(1)
+    expect(lisp read '(begin (- 9 5))').to.equal(4)
+
+  it "Should handle some algebra", ->
+    expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
+
+  it "Should handle a basic setting", ->
+    expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
+
+  it "Should handle a zero arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
+
+  it "Should handle a two arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
+
+  it "Should handle a recursive function", ->
+    expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
+
+  it "Should handle an IIFE", ->
+    expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)
+

test/test_chapter1.coffee

@@ -0,0 +1,48 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+lisp = require '../chapter1/interpreter'
+{read, readForms} = require '../chapter1/reader'
+
+the_false_value = (cons "false", "boolean")
+
+describe "Core interpreter #1", ->
+  it "Should handle true statements", ->
+    expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
+  it "Should handle false statements", ->
+    expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
+  it "Should handle return strings", ->
+    expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
+  it "Should handle return strings when false", ->
+    expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
+  it "Should handle equivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
+  it "Should handle inequivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
+
+  it "Should handle basic arithmetic", ->
+    expect(lisp read '(begin (+ 5 5))').to.equal(10)
+    expect(lisp read '(begin (* 5 5))').to.equal(25)
+    expect(lisp read '(begin (/ 5 5))').to.equal(1)
+    expect(lisp read '(begin (- 9 5))').to.equal(4)
+
+  it "Should handle some algebra", ->
+    expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
+
+  it "Should handle a basic setting", ->
+    expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
+
+  it "Should handle a zero arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
+
+  it "Should handle a two arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
+
+  it "Should handle a recursive function", ->
+    expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
+
+  it "Should handle an IIFE", ->
+    expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)
+

test/test_chapter3-cont.coffee

@@ -0,0 +1,96 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+olisp = require '../chapter3/interpreter'
+{read, readForms} = require '../chapter1/reader'
+
+the_false_value = (cons "false", "boolean")
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+describe "Core interpreter #3: Blocks", ->
+  it "Should handle simple blocks", ->
+    expect(lisp read "(block foo 33)").to.equal(33)
+  it "Should handle the last blocks", ->
+    expect(lisp read "(block foo 1 2 3)").to.equal(3)
+  it "Should handle expressive blocks", ->
+    expect(lisp read "(block foo (+ 5 5))").to.equal(10)
+  it "Should handle basic returns blocks", ->
+    expect(lisp read "(block foo (+ 1 (return-from foo 2)))").to.equal(2)
+  it "Should handle complex returns blocks", ->
+    code = "(block foo ((lambda (exit)(* 2 (block foo (* 3 (exit 5)) )) ) (lambda (x) (return-from foo x)) ) )"
+    expect(lisp read code).to.equal(5)
+  it "Expects an uninitialized return-from to fail", ->
+    expect(-> lisp read "(return-from foo 3)").to.throw("Unknown block label foo")
+  it "Expects to see an obsolete block when called late", ->
+    expect(-> lisp read "((block foo (lambda (x) (return-from foo x))) 3 )")
+      .to.throw("Obsolete continuation")
+  it "Expects to see an obsolete block when called late", ->
+    blocka = "((block a  (* 2 (block b (return-from a (lambda (x) (return-from b x))))) )3 )"
+    expect(-> lisp read blocka).to.throw("Obsolete continuation")
+  it "Expects to see an obsolete block when called late", ->
+    blockb = "((block a (* 2 (block b (return-from a (lambda (x) (return-from a x))))) ) 3 )"
+    expect(-> lisp read blockb).to.throw("Obsolete continuation")
+
+describe "Core interpreter #3: Try/Catch", ->
+  it "doesn't change a simple value", ->
+    expect(lisp read "(catch 'bar 1)").to.equal(1)
+  it "doesn't interfere with standard behavior", ->
+    expect(lisp read "(catch 'bar 1 2 3)").to.equal(3)
+  it "bails at the top level when no catch", ->
+    expect(-> lisp read "(throw 'bar 33)").to.throw("No associated catch")
+  it "catches the throws value", ->
+    expect(lisp read "(catch 'bar (throw 'bar 11))").to.equal(11)
+  it "catches before the evaluation happens", ->
+    expect(lisp read "(catch 'bar (* 2 (throw 'bar 5)))").to.equal(5)
+  it "unrolls through multiple layers of the stack", ->
+    expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (throw 'bar x)))").to.equal(5)
+  it "continues at the right location", ->
+    expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (throw 'bar x)))").to.equal(10)
+  it "throw/catch happens with literalally catches", ->
+    expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (throw 1 (throw 2 5)) )) )))").to.equal(105)
+  it "bails at top level when there aren't enough catches", ->
+    expect(-> lisp read "(catch 2 (* 7 (throw 1 (throw 2 3))))").to.throw("No associated catch")
+
+#describe "Core interpreter #3: Unwind-Protect", ->
+#  it "protects the value correctly", ->
+#    expect(lisp read "(unwind-protect 1 2").to.equal(1)
+#   it "", ->
+#     expect(lisp read "((lambda (c) (unwind-protect 1 (set! c 2)) c ) 0 ").to.equal(2)
+#   it "", ->
+#     expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0 ").to.equal(5)
+#   it "", ->
+#     expect(lisp read "((lambda (c) (catch 111 (* 2 (unwind-protect (* 3 (throw 111 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
+#   it "", ->
+#     expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) ) 0 ").to.equal(5)
+#   it "", ->
+#     expect(lisp read "((lambda (c) (block A (* 2 (unwind-protect (* 3 (return-from A 5)) (set! c 1) ))) c ) 0 ").to.equal(1)
+# 
+# 
+# describe "Core interpreter #3: Try/Catch with Throw as a function", ->
+#   contain = (fcall) ->
+#     return "(begin ((lambda () (begin (set! funcall (lambda (g . args) (apply g args))) #{fcall}))))"
+# 
+#   it "", ->
+#     expect(-> lisp read "(funcall throw 'bar 33").to.throw("bar")
+#   it "", ->
+#     expect(lisp read "(catch 'bar (funcall throw 'bar 11))").to.equal(11)
+#   it "", ->
+#     expect(lisp read "(catch 'bar (* 2 (funcall throw 'bar 5)))").to.equal(5)
+#   it "", ->in
+#     expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (funcall throw 'bar x))) ").to.equal(5)
+#   it "", ->
+#     expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (funcall throw 'bar x)))) ").to.equal(10)
+#   it "", ->
+#     expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (funcall throw 1 (funcall throw 2 5)) )) ))) ").to.equal(105)
+#   it "", ->
+#     expect(lisp read "(catch 2 (* 7 (funcall throw 1 (funcall throw 2 3))))").to.equal(3)
+#  
+# 
+#  
+# 

test/test_chapter3.coffee

@@ -0,0 +1,55 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+olisp = require '../chapter3/interpreter'
+{read, readForms} = require '../chapter1/reader'
+
+the_false_value = (cons "false", "boolean")
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+
+describe "Core interpreter #3", ->
+  it "Should handle true statements", ->
+    expect(lisp read "(begin (if (lt 0 1) #t #f))").to.equal(true)
+  it "Should handle false statements", ->
+    expect(lisp read "(begin (if (lt 1 0) #t #f))").to.deep.equal(the_false_value)
+  it "Should handle return strings", ->
+    expect(lisp read '(begin (if (lt 0 1) "y" "n"))').to.equal("y")
+  it "Should handle return strings when false", ->
+    expect(lisp read '(begin (if (lt 1 0) "y" "n"))').to.equal("n")
+  it "Should handle equivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "y") "y" "n"))').to.equal("y")
+  it "Should handle inequivalent objects that are not intrinsically truthy", ->
+    expect(lisp read '(begin (if (eq? "y" "x") "y" "n"))').to.equal("n")
+
+  it "Should handle basic arithmetic", ->
+    expect(lisp read '(begin (+ 5 5))').to.equal(10)
+    expect(lisp read '(begin (* 5 5))').to.equal(25)
+    expect(lisp read '(begin (/ 5 5))').to.equal(1)
+    expect(lisp read '(begin (- 9 5))').to.equal(4)
+
+  it "Should handle some algebra", ->
+    expect(lisp read '(begin (* (+ 5 5) (* 2 3)))').to.equal(60)
+
+  it "Should handle a basic setting", ->
+    expect(lisp read '(begin (set! fact 4) fact)').to.equal(4)
+
+  it "Should handle a zero arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda () (+ 5 5))) (fact))').to.equal(10)
+
+  it "Should handle a two arity thunk", ->
+    expect(lisp read '(begin (set! fact (lambda (a b) (+ a b))) (fact 4 6))').to.equal(10)
+
+  it "Should handle a recursive function", ->
+    expect(lisp read '(begin (set! fact (lambda (x) (if (eq? x 0) 1 (* x (fact (- x 1)))))) (fact 5))').to.equal(120)
+
+  it "Should handle an IIFE", ->
+    expect(lisp read '(begin ((lambda () (+ 5 5))))').to.equal(10)
+
+

test/test_chapter3g.coffee

@@ -0,0 +1,50 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons} = require "cons-lists/lists"
+olisp = require '../chapter3g/interpreter'
+{read, readForms} = require '../chapter1/reader'
+
+the_false_value = (cons "false", "boolean")
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+  
+describe "Core interpreter #3: Protect", ->
+  it "unwinds but returns the value of the form", ->
+    expect(lisp read "(protect 1 2").to.equal(1)
+   it "unwinds within an iffe to correctly evaluate the side-effect", ->
+     expect(lisp read "((lambda (c) (protect 1 (set! c 2)) c ) 0 ").to.equal(2)
+   it "Unwinds inside an unevaluated definition", ->
+     expect(lisp read "((lambda (c) (catch 111 (* 2 (protect (* 3 (throw 111 5)) (set! c 1) ))) ) 0)").to.equal(5)
+   it "Unwinds inside the evaluated definition, triggering the side effect", ->
+     expect(lisp read "((lambda (c) (catch 111 (* 2 (protect (* 3 (throw 111 5)) (set! c 1) ))) c ) 0)").to.equal(1)
+   it "Same story, using block/return", ->
+     expect(lisp read "((lambda (c) (block A (* 2 (protect (* 3 (return A 5)) (set! c 1) ))) ) 0)").to.equal(5)
+   it "Same story, using block/return with a triggered side-effect", ->
+     expect(lisp read "((lambda (c) (block A (* 2 (protect (* 3 (return A 5)) (set! c 1) ))) c ) 0)").to.equal(1)
+ 
+ 
+#describe "Core interpreter #3: Try/Catch with Throw as a function", ->
+#  contain = (fcall) ->
+#    return "(begin ((lambda () (begin (set! funcall (lambda (g . args) (apply g args))) #{fcall}))))"
+#
+#  it "", ->
+#    expect(-> lisp read "(funcall throw 'bar 33").to.throw("bar")
+#  it "", ->
+#    expect(lisp read "(catch 'bar (funcall throw 'bar 11))").to.equal(11)
+#  it "", ->
+#    expect(lisp read "(catch 'bar (* 2 (funcall throw 'bar 5)))").to.equal(5)
+#  it "", ->
+#    expect(lisp read "((lambda (f) (catch 'bar (* 2 (f 5))) ) (lambda (x) (funcall throw 'bar x))) ").to.equal(5)
+#  it "", ->
+#    expect(lisp read "((lambda (f) (catch 'bar (* 2 (catch 'bar (* 3 (f 5))))) ) (lambda (x) (funcall throw 'bar x)))) ").to.equal(10)
+#  it "", ->
+#    expect(lisp read "(catch 2 (* 7 (catch 1 (* 3 (catch 2 (funcall throw 1 (funcall throw 2 5)) )) ))) ").to.equal(105)
+#  it "", ->
+#    expect(lisp read "(catch 2 (* 7 (funcall throw 1 (funcall throw 2 3))))").to.equal(3)
+ 
+

test/test_chapter4.coffee

@@ -0,0 +1,43 @@
+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 symbol equality", ->
+    expect(lisp read "(eq? 'a 'b)").to.equal(false)
+    expect(lisp read "(eq? 'a 'a)").to.equal(true)
+  it "Understands separate allocation inequality", ->
+    expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
+  it "Understands address equality", ->
+    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)
+  it "Understands function inequality", ->
+    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)
+

test/test_chapter5a.coffee

@@ -0,0 +1,27 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+olisp = require '../chapter5/interpreter5a'
+{read} = require '../chapter5/reader'
+
+lisp = (ast) ->
+  ret = undefined
+  olisp ast, (i) -> ret = i
+  return ret
+
+describe "Core interpreter #5: Now with more λ!", ->
+  it "Understands symbol inequality", ->
+    expect(lisp read "(eq? 'a 'b)").to.equal(false)
+  it "Understands symbol equality", ->
+    expect(lisp read "(eq? 'a 'a)").to.equal(true)
+  it "Understands separate allocation inequality", ->
+    expect(lisp read "(eq? (cons 1 2) (cons 1 2))").to.equal(false)
+  it "Understands address equality of values", ->
+    expect(lisp read "((lambda (a) (eq? a a)) (cons 1 2))").to.equal(true)
+  it "Understands address equality of functions", ->
+    expect(lisp read "((lambda (a) (eq? a a)) (lambda (x) x))").to.equal(true)
+  it "Understands function inequality", ->
+    expect(lisp read "(eq? (lambda (x) 1) (lambda (x y) 2))").to.equal(false)
+
+

test/test_reader.coffee

@@ -0,0 +1,35 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons, nil, nilp} = require "cons-lists/lists"
+{read, readForms} = require '../chapter1/reader'
+{normalizeForm} = require '../chapter1/astToList'
+
+describe "Core reader functions", ->
+  samples = [
+    ['nil', nil]
+    ['0', 0]
+    ['1', 1]
+    ['500', 500]
+    ['0xdeadbeef', 3735928559]
+    ['"Foo"', 'Foo']
+    ['(1)', cons(1)]
+    ['(1 2)', cons(1, (cons 2))]
+    ['(1 2 )', cons(1, (cons 2))]
+    ['( 1 2 )', cons(1, (cons 2))]
+    ['(   1   2   )', cons(1, (cons 2))]
+    ['("a" "b")', cons("a", (cons "b"))]
+    ['("a" . "b")', cons("a", "b")]
+    ['[]', []]
+    ['{}', {}]
+    ['[1 2 3]', [1, 2, 3]]
+    # ['(1 2 3', 'error']
+    ['{"foo" "bar"}', {foo: "bar"}]
+  ]
+
+  for [t, v] in samples
+    do (t, v) ->
+      it "should interpret #{t} as #{v}", ->
+        res = normalizeForm read t
+        expect(res).to.deep.equal(v)

test/test_reader5a.coffee

@@ -0,0 +1,15 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons, nil, nilp} = require "cons-lists/lists"
+{read} = require '../chapter5/reader'
+{normalize} = require '../chapter5/reader_rawtoform'
+{samples} = require './reader5_samples'
+
+describe "Lisp reader functions", ->
+  for [t, v] in samples
+    do (t, v) ->
+      it "should interpret #{t} as #{v}", ->
+        res = normalize read t
+        expect(res).to.deep.equal(v)

test/test_reader5b.coffee

@@ -0,0 +1,15 @@
+chai = require 'chai'
+chai.should()
+expect = chai.expect
+
+{cons, nil, nilp} = require "cons-lists/lists"
+{read} = require '../chapter5/tracking_reader'
+{normalize} = require '../chapter5/reader_tracktoform'
+{samples} = require './reader5_samples'
+
+describe "Tracker reader functions", ->
+  for [t, v] in samples
+    do (t, v) ->
+      it "should interpret #{t} as #{v}", ->
+        res = normalize read t
+        expect(res).to.deep.equal(v)