still chasing after browser bug; the simulator is working ok, so I assume I messed up somewhere in assembly

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)"
+     (format "captureControl(MACHINE, ~a, ~a)"
-             (CaptureControl-skip op))]
+             (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)

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'; };
 
 

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)

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.
+;; This should produce 1 because there's a continuation prompt around each evaluation,
-#;(test '(begin 
+;; 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,15 +942,12 @@
            (if (< n 10)
              (cont 'dontcare))
            n)
-        0
+        1
         #:with-bootstrapping? #t)
 
 
 
-
+(test '(begin
-;; 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 ()
@@ -969,13 +967,14 @@
          
          (g1)
          (g1))
-        "b")
+      "b"
+      #:with-bootstrapping? #t)
 
 
 
-;; FIXME: this test is failing.  I think we need prompts to delimit
+(let ([op (open-output-string)])
-;; the continuation capture.
+  (parameterize ([current-simulated-output-port op])
-#;(test '(begin
+    (test '(begin
              (define (make-gen gen) 
                (let ([cont (box #f)])     
                  (lambda ()
@@ -996,8 +995,10 @@
              (displayln (g1))
              (displayln (g1))
              (displayln (g1)))
-        "a\nb\nc\n"
+          (void)
-        #:with-bootstrapping #t)
+          #:with-bootstrapping? #t))
+  (unless (string=? (get-output-string op) "a\nb\nc\n")
+    (error 'failure)))