[feat] Most throw/catch conditions work.

I've hit a snag with respect to self-evaluating objects, and the ad-hoc evaluation of
program labels is messed up because of it.  I'm going to have to refactor.
Oddly enough, the strategy I hit upon appears to be the same one found
in Wisp, rather than Clojurescript.

This may actually be an internal detail; the version rendered for the user may actually
not care.  I hope not; the performance could become hairy pretty quickly.

.gitignore

@@ -12,3 +12,4 @@ bin/coffee
 bin/cake
 test-reports.xml
 LisperatorLanguage
+chapter?/test.coffee

chapter3/interpreter.coffee

@@ -1,8 +1,10 @@
 {listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
  cadr, caadr, cadar, caddr, nilp, nil, setcdr,
  metacadr, setcar} = require "cons-lists/lists"
+{normalizeForm} = require "../chapter1/astToList"
 readline = require "readline"
 {inspect} = require "util"
+minspect = (obj) -> inspect obj, false, null, true
 
 class LispInterpreterError extends Error
   name: 'LispInterpreterError'
@@ -28,6 +30,8 @@ class Continuation
       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
 
@@ -93,6 +97,7 @@ evaluateQuote = (v, env, kont) ->
 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"
@@ -224,6 +229,8 @@ class BottomCont extends Continuation
     @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)
@@ -251,6 +258,47 @@ class ReturnFromCont extends Continuation
   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) ->
+    console.log(value)
+    evaluateBegin @body, @env, (new LabeledCont @kont, normalizeForm car value)
+
+class LabeledCont extends Continuation
+  constructor: (@kont, @tag) ->
+  resume: (value) ->
+    @kont.resume value
+  catchLookup: (tag, kk) ->
+    if tag == @tag
+      console.log 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 (normalizeForm car 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"
@@ -348,6 +396,12 @@ definitial "apply", new Primitive "apply", (values, env, kont) ->
         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)
 

test/test_chapter3-cont.coffee

@@ -37,4 +37,60 @@ describe "Core interpreter #3: Blocks", ->
     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 right thing", ->
+    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 unlabled 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 test")
 
+# 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)
+#  
+# 
+#  
+#