Start of chapter 5 interpreters. New readers, too.

chapter5/interpreter5a.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)

chapter5/reader.coffee

@@ -0,0 +1,203 @@
+{car, cdr, cons, nil, nilp, pairp, vectorToList, list} = require 'cons-lists/lists'
+{inspect} = require "util"
+{Node, Comment, Symbol} = require "../chapter5/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 -> IO, Node)
+handleError = (message) ->
+  (line, column) -> new Node('error', message, line, column)
+
+# IO -> (IO, Node)
+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 -> (IO, Node) | 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) -> (Symbol | 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 (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 -> IO, Node
+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 -> (IO, Nodes* | Error)
+readForms = (inStream) ->
+  inStream = if inStream instanceof Source then inStream else new Source inStream
+  return nil if inStream.done()
+
+  # IO -> (IO, Nodes* | 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/reader_types.coffee

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