From 39f6a09d51c371ad91300b1072e60458906fa498 Mon Sep 17 00:00:00 2001 From: "Elf M. Sternberg" Date: Tue, 21 Jul 2015 16:16:13 -0700 Subject: [PATCH] [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 | 1 + chapter3/interpreter.coffee | 58 ++++++++++++++++++++++++++++++++-- test/test_chapter3-cont.coffee | 58 +++++++++++++++++++++++++++++++++- 3 files changed, 114 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index ffd8c6e..2dd83a7 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,4 @@ bin/coffee bin/cake test-reports.xml LisperatorLanguage +chapter?/test.coffee diff --git a/chapter3/interpreter.coffee b/chapter3/interpreter.coffee index bcc3fac..d5d3469 100644 --- a/chapter3/interpreter.coffee +++ b/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" @@ -302,8 +350,8 @@ defprimitive = (name, nativ, arity) -> vmargs = listToVector(args) if (vmargs.length == arity) kont.resume (nativ.apply null, vmargs) - else - throw new LispInterpreterError "Incorrect arity" + 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 @@ -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) diff --git a/test/test_chapter3-cont.coffee b/test/test_chapter3-cont.coffee index 995287c..b6c4510 100644 --- a/test/test_chapter3-cont.coffee +++ b/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) +# +# +# +#