still debugging

compile.rkt

@@ -21,7 +21,8 @@
 ;; Note: the toplevel generates the lambda body streams at the head, and then the
 ;; rest of the instruction stream.
 (define (-compile exp target linkage)
-  (let ([after-lam-bodies (make-label 'afterLamBodies)])
+  (let ([after-lam-bodies (make-label 'afterLamBodies)]
+        [before-pop-prompt (make-label 'beforePopPrompt)])
     (statements
      (end-with-linkage 
       linkage '() 
@@ -30,11 +31,15 @@
                                     (compile-lambda-bodies (collect-all-lams exp))
                                     after-lam-bodies
                                     (make-instruction-sequence
-                                     `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag)))
+                                     `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
+                                                                      before-pop-prompt)))
                                     (compile exp
                                              '()
                                              target 
-                                             next-linkage)
+                                             (make-LabelLinkage before-pop-prompt))
+
+                                    before-pop-prompt
+
                                     (make-instruction-sequence
                                      `(,(make-PopControlFrame))))))))
 
@@ -310,21 +315,28 @@
 ;; Wrap a continuation prompt around each of the expressions.
 (define (compile-splice seq cenv target linkage) 
   (cond [(last-exp? seq)
-         (end-with-linkage 
+         (let ([before-pop-prompt (make-label 'beforePromptPop)])
-          linkage
+           (end-with-linkage 
-          cenv
+            linkage
-          (append-instruction-sequences 
+            cenv
-           (make-instruction-sequence `(,(make-PushControlFrame/Prompt
+            (append-instruction-sequences 
-                                          default-continuation-prompt-tag)))
+             (make-instruction-sequence `(,(make-PushControlFrame/Prompt
-           (compile (first-exp seq) cenv target next-linkage)
+                                            default-continuation-prompt-tag
-           (make-instruction-sequence `(,(make-PopControlFrame)))))]
+                                            before-pop-prompt
+                                            )))
+             (compile (first-exp seq) cenv target next-linkage)
+             before-pop-prompt
+             (make-instruction-sequence `(,(make-PopControlFrame))))))]
         [else
-         (append-instruction-sequences 
+         (let ([before-pop-prompt (make-label 'beforePromptPop)])
-          (make-instruction-sequence `(,(make-PushControlFrame/Prompt
+           (append-instruction-sequences 
-                                         (make-DefaultContinuationPromptTag))))
+            (make-instruction-sequence `(,(make-PushControlFrame/Prompt
-          (compile (first-exp seq) cenv target next-linkage)
+                                           (make-DefaultContinuationPromptTag)
-          (make-instruction-sequence `(,(make-PopControlFrame)))
+                                           before-pop-prompt)))
-          (compile-splice (rest-exps seq) cenv target linkage))]))
+            (compile (first-exp seq) cenv target next-linkage)
+            before-pop-prompt
+            (make-instruction-sequence `(,(make-PopControlFrame)))
+            (compile-splice (rest-exps seq) cenv target linkage)))]))
 
 
 

il-structs.rkt

@@ -100,6 +100,7 @@
   #:transparent)
 
 (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
+                                         [label : Symbol]
                                          ;; TODO: add handler and arguments
                                          )
   #:transparent)

simulator-structs.rkt

@@ -63,7 +63,8 @@
                            ;; TODO: add continuation marks
                            )
   #:transparent)
-(define-struct: PromptFrame ([tag : ContinuationPromptTagValue])
+(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
+                             [label : Symbol])
   #:transparent)
 
 (define-struct: ContinuationPromptTagValue ([name : Symbol])

simulator.rkt

@@ -163,7 +163,8 @@
                         [(DefaultContinuationPromptTag? tag)
                          default-continuation-prompt-tag-value]
                         [(OpArg? tag)
-                         (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))])))))
+                         (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))
+                    (PushControlFrame/Prompt-label stmt))))
                         
   
 
@@ -267,7 +268,7 @@
                                   default-continuation-prompt-tag-value]
                                  [(OpArg? tag)
                                   (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))])
-                 (set-machine-control! m (append 
+                 (set-machine-control! m (compose-continuation-frames 
                                           (CapturedControl-frames (ensure-CapturedControl (env-ref m 0)))
                                           (drop-continuation-to-tag (machine-control m)
                                                                     tag-value)))
@@ -279,6 +280,34 @@
            'ok])))
 
 
+
+(: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame)))
+;; Stitch together the continuation.  A PromptFrame must exist at the head of frames-2.
+(define (compose-continuation-frames frames-1 frames-2)
+  (let ([prompt-frame (ensure-prompt-frame (first frames-2))]
+        [last-frame (last frames-1)])
+    (let ([result
+           (append #;frames-1 
+                   (drop-right frames-1 1)
+                   (list (cond
+                           [(CallFrame? last-frame)
+                            last-frame #; (update-call-frame-return last-frame (PromptFrame-label prompt-frame))]
+                           [(PromptFrame? last-frame)
+                            last-frame]))
+                   frames-2)])
+      ;(displayln frames-1)
+      ;(displayln frames-2)
+      ;(displayln result)
+      result)))
+
+(: update-call-frame-return (CallFrame Symbol -> CallFrame))
+(define (update-call-frame-return a-call-frame a-return)
+  (make-CallFrame a-return 
+                  (CallFrame-proc a-call-frame)))
+
+
+
+
 (: get-target-updater (Target -> (machine SlotValue -> 'ok)))
 (define (get-target-updater t)
   (cond
@@ -612,6 +641,11 @@
       x
       (error 'ensure-mutable-pair "not a mutable pair: ~s" x)))
 
+(: ensure-prompt-frame (Any -> PromptFrame))
+(define (ensure-prompt-frame x)
+  (if (PromptFrame? x)
+      x
+      (error 'ensure-prompt-frame "not a PromptFrame: ~s" x)))
 
 
 (: ensure-CapturedControl (Any -> CapturedControl))

test-compiler.rkt

@@ -826,7 +826,7 @@
 
 
 ;; This should produce 0 because there needs to be a continuation prompt around each evaluation.
-#;(test '(begin 
+(test '(begin 
            (define cont #f)
            (define n 0)
            (call/cc (lambda (x) (set! cont x)))