From 1b695bed468665c0586057446d6501270050c7ed Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 18 Apr 2013 16:23:01 -0600 Subject: [PATCH] adding continuation-prompt-available? so we can do context checks. --- whalesong/compiler/kernel-primitives.rkt | 1 + .../runtime-src/baselib-contmarks.js | 21 ++++++++++++--- .../runtime-src/baselib-functions.js | 1 - .../runtime-src/baselib-primitives.js | 26 +++++++++++++++++-- whalesong/js-assembler/runtime-src/runtime.js | 2 +- whalesong/lang/kernel.rkt | 2 +- whalesong/lang/private/call-ec.rkt | 8 ++++-- 7 files changed, 50 insertions(+), 11 deletions(-) diff --git a/whalesong/compiler/kernel-primitives.rkt b/whalesong/compiler/kernel-primitives.rkt index 7bc81ac..481a5d6 100644 --- a/whalesong/compiler/kernel-primitives.rkt +++ b/whalesong/compiler/kernel-primitives.rkt @@ -210,6 +210,7 @@ 'unsafe-car 'unsafe-cdr + 'continuation-prompt-available? 'abort-current-continuation 'call-with-continuation-prompt )) diff --git a/whalesong/js-assembler/runtime-src/baselib-contmarks.js b/whalesong/js-assembler/runtime-src/baselib-contmarks.js index 7ea8996..e65a20a 100644 --- a/whalesong/js-assembler/runtime-src/baselib-contmarks.js +++ b/whalesong/js-assembler/runtime-src/baselib-contmarks.js @@ -84,22 +84,35 @@ // A continuation prompt tag labels a prompt frame. var ContinuationPromptTag = function(name) { - this.name = name; // String + this.name = name; // (U String false) }; ContinuationPromptTag.prototype.toDomNode = function(params) { var dom = document.createElement("span"); - dom.appendChild(document.createTextNode('#')); + if (this.name) { + dom.appendChild(document.createTextNode('#')); + } else { + dom.appendChild(document.createTextNode('#')); + } return dom; }; ContinuationPromptTag.prototype.toWrittenString = function(cache) { - return '#'; + if (this.name) { + return '#'; + } else { + return '#'; + } }; ContinuationPromptTag.prototype.toDisplayedString = function(cache) { - return '#'; + if (this.name) { + return '#'; + } else { + return '#'; + } }; diff --git a/whalesong/js-assembler/runtime-src/baselib-functions.js b/whalesong/js-assembler/runtime-src/baselib-functions.js index bfe3a08..d2e0045 100644 --- a/whalesong/js-assembler/runtime-src/baselib-functions.js +++ b/whalesong/js-assembler/runtime-src/baselib-functions.js @@ -225,7 +225,6 @@ "Not a procedure: ~e", [proc]), MACHINE.captureContinuationMarks())); - } oldVal = MACHINE.v; diff --git a/whalesong/js-assembler/runtime-src/baselib-primitives.js b/whalesong/js-assembler/runtime-src/baselib-primitives.js index f9728b3..76b12ff 100644 --- a/whalesong/js-assembler/runtime-src/baselib-primitives.js +++ b/whalesong/js-assembler/runtime-src/baselib-primitives.js @@ -2810,7 +2810,7 @@ sym = checkSymbol(M, "make-continuation-prompt-tag", 0); return new baselib.contmarks.ContinuationPromptTag(sym.toString()); } - return new baselib.contmarks.ContinuationPromptTag(void(0)); + return new baselib.contmarks.ContinuationPromptTag(false); }); installPrimitiveProcedure( @@ -3164,6 +3164,28 @@ }; + // FIXME: we should be able to take in an arbitrary continuation + // as an optional second argument! + // + // I need to change the representation of continuations to be able to + // detect this at runtime. + installPrimitiveProcedure( + 'continuation-prompt-available?', + 1, + function(M) { + var promptTag = checkPromptTag(M, 'continuation-prompt-available?', 0); + var i; + for (i = 0; i < M.c.length; i++) { + var frame = M.c[i]; + if (frame instanceof PromptFrame && frame.tag === promptTag) { + return true; + } + } + return false; + }); + + + // The default abort prompt handler consumes a thunk and applies // it, in a context where a new prompt has been initialized. var defaultPromptHandler = @@ -3185,7 +3207,7 @@ // First, find the continuation prompt. while(true) { frame = M.c.pop(); - if (frame instanceof PromptFrame) { + if (frame instanceof PromptFrame && frame.tag === promptTag) { break; } else if (M.c.length === 0) { raiseContractError( diff --git a/whalesong/js-assembler/runtime-src/runtime.js b/whalesong/js-assembler/runtime-src/runtime.js index f2838ce..4cdad38 100644 --- a/whalesong/js-assembler/runtime-src/runtime.js +++ b/whalesong/js-assembler/runtime-src/runtime.js @@ -501,7 +501,7 @@ }; Machine.prototype.addPrompt = function(promptTag, abortHandlerClosure) { this.c.push(new PromptFrame(justReturn, - DEFAULT_CONTINUATION_PROMPT_TAG, + promptTag, this.e.length, abortHandlerClosure)); }; diff --git a/whalesong/lang/kernel.rkt b/whalesong/lang/kernel.rkt index ee501e8..3c7594e 100644 --- a/whalesong/lang/kernel.rkt +++ b/whalesong/lang/kernel.rkt @@ -228,7 +228,7 @@ current-inexact-milliseconds current-seconds - + continuation-prompt-available? abort-current-continuation call-with-continuation-prompt diff --git a/whalesong/lang/private/call-ec.rkt b/whalesong/lang/private/call-ec.rkt index 27b20f1..60e286c 100644 --- a/whalesong/lang/private/call-ec.rkt +++ b/whalesong/lang/private/call-ec.rkt @@ -9,12 +9,16 @@ (define (call-with-escape-continuation proc) - (define p (make-continuation-prompt-tag)) + (define p (make-continuation-prompt-tag 'escape)) (call-with-continuation-prompt (lambda () (proc (lambda args + (unless (continuation-prompt-available? p) + (error 'call-with-escape-continuation + "escape continuation used out of context")) (abort-current-continuation p (lambda () - (apply values args)))))))) + (apply values args)))))) + p)) (define call/ec (procedure-rename call-with-escape-continuation 'call/ec))