diff --git a/assemble.rkt b/assemble.rkt index f4f7bb2..685b87d 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -204,7 +204,11 @@ EOF empty] [(PushControlFrame? stmt) (list (PushControlFrame-label stmt))] + [(PushControlFrame/Prompt? stmt) + (list (PushControlFrame/Prompt-label stmt))] [(PopControlFrame? stmt) + empty] + [(PopControlFrame/Prompt? stmt) empty]) (loop (rest stmts))))])))) @@ -261,9 +265,21 @@ EOF (assemble-jump (GotoStatement-target stmt))] [(PushControlFrame? stmt) - (format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] + (format "MACHINE.control.push(new CallFrame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] + [(PushControlFrame/Prompt? stmt) + ;; fixme: use a different frame structure + (format "MACHINE.control.push(new PromptFrame(~a, ~a));" + (PushControlFrame/Prompt-label stmt) + (let ([tag (PushControlFrame/Prompt-tag stmt)]) + (cond + [(DefaultContinuationPromptTag? tag) + (assemble-default-continuation-prompt-tag)] + [(OpArg? tag) + (assemble-oparg tag)])))] [(PopControlFrame? stmt) "MACHINE.control.pop();"] + [(PopControlFrame/Prompt? stmt) + "MACHINE.control.pop();"] [(PushEnvironment? stmt) (format "MACHINE.env.push(~a);" (string-join (build-list (PushEnvironment-n stmt) @@ -345,8 +361,14 @@ EOF (CaptureEnvironment-skip op))] [(CaptureControl? op) - (format "MACHINE.control.slice(0, MACHINE.control.length - ~a)" - (CaptureControl-skip op))] + (format "captureControl(MACHINE, ~a, ~a)" + (CaptureControl-skip op) + (let ([tag (CaptureControl-tag op)]) + (cond [(DefaultContinuationPromptTag? tag) + (assemble-default-continuation-prompt-tag)] + [(OpArg? tag) + (assemble-oparg tag)])))] + [(MakeBoxedEnvironmentValue? op) (format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]" @@ -356,6 +378,10 @@ EOF (open-code-kernel-primitive-procedure op)])) +(: assemble-default-continuation-prompt-tag (-> String)) +(define (assemble-default-continuation-prompt-tag) + "DEFAULT_CONTINUATION_PROMPT_TAG") + @@ -406,7 +432,13 @@ EOF [(RestoreEnvironment!? op) "MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"] [(RestoreControl!? op) - "MACHINE.control = MACHINE.env[MACHINE.env.length - 1].slice(0);"] + (format "restoreControl(MACHINE, ~a);" + (let ([tag (RestoreControl!-tag op)]) + (cond + [(DefaultContinuationPromptTag? tag) + (assemble-default-continuation-prompt-tag)] + [(OpArg? tag) + (assemble-oparg tag)])))] [(FixClosureShellMap!? op) (format "MACHINE.env[MACHINE.env.length - 1 - ~a].closedVals = [~a]" (FixClosureShellMap!-depth op) diff --git a/runtime.js b/runtime.js index 926afed..f21ae7c 100644 --- a/runtime.js +++ b/runtime.js @@ -11,11 +11,17 @@ // No error trapping at the moment. -var Frame = function(label, proc) { +var CallFrame = function(label, proc) { this.label = label; this.proc = proc; }; +var PromptFrame = function(label, tag) { + this.label = label; + this.tag = tag; +}; + + // A closure consists of its free variables as well as a label @@ -27,6 +33,14 @@ var Closure = function(label, arity, closedVals, displayName) { this.displayName = displayName; }; +var ContinuationPromptTag = function(name) { + this.name = name; +}; + +var DEFAULT_CONTINUATION_PROMPT_TAG = + new ContinuationPromptTag("default-continuation-prompt-tag"); + + // A primitive function is just a Javascript function. @@ -51,6 +65,37 @@ var testArgument = function(expectedTypeName, } }; + + + +var captureControl = function(MACHINE, skip, tag) { + var i; + for (i = MACHINE.control.length - skip - 1; i >= 0; i--) { + if (MACHINE.control[i].tag === tag) { + return MACHINE.control.slice(i, MACHINE.control.length - skip); + } + } + raise(new Error("captureControl: unable to find tag " + tag)); +}; + + +var restoreControl = function(MACHINE, tag) { + var i; + for (i = MACHINE.control.length - 1; i >= 0; i--) { + if (MACHINE.control[i].tag === tag) { + MACHINE.control = + MACHINE.control.slice(0, i+1).concat( + MACHINE.env[MACHINE.env.length - 1].slice(0)); + return; + } + } + raise(new Error("restoreControl: unable to find tag " + tag)); + +} + + + + var isNumber = function(x) { return typeof(x) === 'number'; }; diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index e4e8897..ee87f98 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -38,7 +38,7 @@ EOF (with-syntax ([stx stx]) (syntax/loc #'stx (begin - (printf "running test...") + (printf "running test... ~s" (syntax->datum #'stx)) (let ([result (evaluate s)]) (let ([output (evaluated-stdout result)]) (unless (string=? output exp) diff --git a/test-compiler.rkt b/test-compiler.rkt index 509ce91..4abf689 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -892,7 +892,7 @@ -#;(test '(begin +(test '(begin (define (make-gen gen) (let ([cont (box #f)]) (lambda () @@ -913,13 +913,13 @@ (list (g1))) (list "a") - #:with-bootstrapping #t) + #:with-bootstrapping? #t) -#;(test '(begin (define (f) +(test '(begin (define (f) (define cont #f) (define n 0) (call/cc (lambda (x) (set! cont x))) @@ -929,11 +929,12 @@ n) (f)) 10 - #:with-bootstrapping #t) + #:with-bootstrapping? #t) -;; This should produce 0 because there needs to be a continuation prompt around each evaluation. -#;(test '(begin +;; This should produce 1 because there's a continuation prompt around each evaluation, +;; and the call/cc cuts off at the prompt. +(test '(begin (define cont #f) (define n 0) (call/cc (lambda (x) (set! cont x))) @@ -941,63 +942,63 @@ (if (< n 10) (cont 'dontcare)) n) - 0 + 1 #:with-bootstrapping? #t) - -;; FIXME: this test is failing. I think we need prompts to delimit -;; the continuation capture. -#;(test '(begin - (define (make-gen gen) - (let ([cont (box #f)]) - (lambda () - (call/cc (lambda (caller) - (if (unbox cont) - ((unbox cont) caller) - (gen (lambda (v) - (call/cc (lambda (gen-k) - (begin - (set-box! cont gen-k) - (caller v)))))))))))) - - (define g1 (make-gen (lambda (return) - (return "a") - (return "b") - (return "c")))) - - (g1) - (g1)) - "b") +(test '(begin + (define (make-gen gen) + (let ([cont (box #f)]) + (lambda () + (call/cc (lambda (caller) + (if (unbox cont) + ((unbox cont) caller) + (gen (lambda (v) + (call/cc (lambda (gen-k) + (begin + (set-box! cont gen-k) + (caller v)))))))))))) + + (define g1 (make-gen (lambda (return) + (return "a") + (return "b") + (return "c")))) + + (g1) + (g1)) + "b" + #:with-bootstrapping? #t) -;; FIXME: this test is failing. I think we need prompts to delimit -;; the continuation capture. -#;(test '(begin - (define (make-gen gen) - (let ([cont (box #f)]) - (lambda () - (call/cc (lambda (caller) - (if (unbox cont) - ((unbox cont) caller) - (gen (lambda (v) - (call/cc (lambda (gen-k) - (begin - (set-box! cont gen-k) - (caller v)))))))))))) - - (define g1 (make-gen (lambda (return) - (return "a") - (return "b") - (return "c")))) - - (displayln (g1)) - (displayln (g1)) - (displayln (g1))) - "a\nb\nc\n" - #:with-bootstrapping #t) +(let ([op (open-output-string)]) + (parameterize ([current-simulated-output-port op]) + (test '(begin + (define (make-gen gen) + (let ([cont (box #f)]) + (lambda () + (call/cc (lambda (caller) + (if (unbox cont) + ((unbox cont) caller) + (gen (lambda (v) + (call/cc (lambda (gen-k) + (begin + (set-box! cont gen-k) + (caller v)))))))))))) + + (define g1 (make-gen (lambda (return) + (return "a") + (return "b") + (return "c")))) + + (displayln (g1)) + (displayln (g1)) + (displayln (g1))) + (void) + #:with-bootstrapping? #t)) + (unless (string=? (get-output-string op) "a\nb\nc\n") + (error 'failure)))