LispInSmallPieces/chapter3g/interpreter.coffee

{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