need to do something about the linkage and describe tail behavior separately from environment/clearing behavior

compiler.rkt

@@ -1267,8 +1267,11 @@
 
 
 
+
 (: compile-with-cont-mark (WithContMark CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-with-cont-mark exp cenv target linkage)
+  (cond
+    [(ReturnLinkage? linkage)
      (append-instruction-sequences
       (compile (WithContMark-key exp) cenv 'val next-linkage)
       (make-instruction-sequence `(,(make-AssignImmediateStatement
@@ -1277,11 +1280,52 @@
       (compile (WithContMark-value exp) cenv 'val next-linkage)
       (make-instruction-sequence `(,(make-PerformStatement
                                      (make-InstallContinuationMarkEntry!))))
-   (compile (WithContMark-body exp) cenv target linkage)))
+      (compile (WithContMark-body exp) cenv target linkage))]
-
-
-
     
+    [(or (NextLinkage? linkage)
+         (PromptLinkage? linkage)
+         (LabelLinkage? linkage))
+     (let* ([after-key-multiple (make-label 'afterKeyMultiple)]
+            [after-key (make-LinkedLabel (make-label 'afterKey) after-key-multiple)]
+            [after-value-multiple (make-label 'afterValueMultiple)]
+            [after-value (make-LinkedLabel (make-label 'afterValue) after-value-multiple)]
+            [after-body-multiple (make-label 'afterBody)]
+            [after-body (make-LinkedLabel (make-label 'afterBody) after-body-multiple)])
+       (end-with-linkage 
+        linkage cenv
+        (append-instruction-sequences
+         (make-instruction-sequence 
+          `(,(make-AssignImmediateStatement 'proc (make-Const #f))
+            ,(make-PushControlFrame after-key)))
+         (compile (WithContMark-key exp) cenv 'val prompt-linkage)
+         after-key-multiple
+         ;; Fixme: we should error out here instead
+         (make-instruction-sequence 
+          `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
+         after-key
+         (make-instruction-sequence `(,(make-AssignImmediateStatement
+                                        (make-ControlFrameTemporary 'pendingContinuationMarkKey)
+                                        (make-Reg 'val))))
+         (make-instruction-sequence 
+          `(,(make-AssignImmediateStatement 'proc (make-Const #f))
+            ,(make-PushControlFrame after-value)))
+         (compile (WithContMark-value exp) cenv 'val prompt-linkage)
+         after-value-multiple
+         ;; Fixme: we should error out here instead
+         (make-instruction-sequence 
+          `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
+         after-value
+         (make-instruction-sequence `(,(make-PerformStatement
+                                        (make-InstallContinuationMarkEntry!))))
+         (make-instruction-sequence 
+          `(,(make-AssignImmediateStatement 'proc (make-Const #f))
+            ,(make-PushControlFrame after-body)))
+         (compile (WithContMark-body exp) cenv target prompt-linkage)
+         after-body-multiple
+         ;; Fixme: we should error out here instead
+         (make-instruction-sequence 
+          `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
+         after-body)))]))
 
 
 

simulator-primitives.rkt

@@ -154,6 +154,22 @@
                          'current-continuation-marks)))
                         
 
+(define continuation-mark-set->list
+  ;; not quite correct: ContinuationMarkSets need to preserve frame structure a bit more. 
+  ;; At the very least, we need to keep track of prompt tags somewhere.
+  (let ([f (lambda (a-machine mark-set key)
+             (let ([marks (ContinuationMarkSet-marks mark-set)])
+               (foldr make-MutablePair
+                      null
+                      (map cdr (filter (lambda (k+v)
+                                         (eq? (car k+v) key))
+                                       marks)))))])
+    (make-primitive-proc (lambda (machine . args) (apply f machine args))
+                         '2 ;; fixme: should deal with prompt tags too
+                         'current-continuation-marks)))
+
+
+
 
 
 (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= 
@@ -206,6 +222,7 @@
                                                      
                                                      symbol?)
                                       #:constants (null pi e
-                                                        current-continuation-marks)))
+                                                        current-continuation-marks
+                                                        continuation-mark-set->list)))
 
 

simulator.rkt

@@ -740,7 +740,7 @@
 (define (ensure-closure-or-false v)
   (if (or (closure? v) (eq? v #f))
       v
-      (error 'ensure-closure)))
+      (error 'ensure-closure-or-false)))
 
 (: ensure-closure (SlotValue -> closure))
 (define (ensure-closure v)

test-compiler.rkt

@@ -1087,6 +1087,54 @@
       (make-ContinuationMarkSet (list (cons 'name "danny"))))
 
 
+(test '(begin (define (extract-current-continuation-marks key)
+                (continuation-mark-set->list
+                 (current-continuation-marks)
+                 key))
+              (with-continuation-mark 'key 'mark
+                (extract-current-continuation-marks 'key)))
+      '(mark))
+
+
+
+(test '(begin (define (extract-current-continuation-marks key)
+                (continuation-mark-set->list
+                 (current-continuation-marks)
+                 key))
+              
+              
+              (with-continuation-mark 'key1 'mark1
+                (with-continuation-mark 'key2 'mark2
+                  (list
+                   (extract-current-continuation-marks 'key1)
+                   (extract-current-continuation-marks 'key2)))))
+              
+      '((mark1) (mark2)))
+
+
+(test '(begin (define (extract-current-continuation-marks key)
+                (continuation-mark-set->list
+                 (current-continuation-marks)
+                 key))
+              (with-continuation-mark 'key 'mark1
+                (with-continuation-mark 'key 'mark2 ; replaces previous mark
+                  (extract-current-continuation-marks 'key))))
+      '(mark2))
+
+
+;; Hmm... something is failing here.
+#;(test '(begin (define (extract-current-continuation-marks key)
+                  (continuation-mark-set->list
+                   (current-continuation-marks)
+                   key))
+                
+                (with-continuation-mark 'key 'mark1
+                  (list ; continuation extended to evaluate the argument
+                   (with-continuation-mark 'key 'mark2
+                     (extract-current-continuation-marks 'key)))))
+        '((mark2 mark1)))
+
+              
 #;(test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt")))