in the middle

parse.rkt

@@ -147,6 +147,12 @@
                                             (parse (set!-value exp) cenv #f))])
                        (make-Constant (void)))))]
     
+    [(with-continuation-mark? exp)
+     (make-WithContMark (parse (with-continuation-mark-key exp) cenv #f)
+                        (parse (with-continuation-mark-value exp) cenv #f)
+                        (parse (with-continuation-mark-body exp) cenv #f))]
+                        
+
     ;; Remember, this needs to be the last case.
     [(application? exp)
      (let ([cenv-with-scratch-space
@@ -272,6 +278,11 @@
         (cons (set!-name exp)
               (loop (set!-value exp)))]
        
+       [(with-continuation-mark? exp)
+        (append (loop (with-continuation-mark-key exp))
+                (loop (with-continuation-mark-value exp))
+                (loop (with-continuation-mark-body exp)))]
+
        ;; Remember: this needs to be the last case.
        [(application? exp)
         (append (loop (operator exp))
@@ -335,6 +346,11 @@
         (cons (set!-name exp)
               (loop (set!-value exp)))]
 
+       [(with-continuation-mark? exp)
+        (append (loop (with-continuation-mark-key exp))
+                (loop (with-continuation-mark-value exp))
+                (loop (with-continuation-mark-body exp)))]
+       
        ;; Remember, this needs to be the last case.
        [(application? exp)
         (append (loop (operator exp))
@@ -465,6 +481,19 @@
               ,(loop (cdr clauses))))])))
 
 
+(define (with-continuation-mark? exp)
+  (tagged-list? exp 'with-continuation-mark))
+
+(define (with-continuation-mark-key exp)
+  (cadr exp))
+(define (with-continuation-mark-value exp)
+  (caddr exp))
+(define (with-continuation-mark-body exp)
+  (cadddr exp))
+
+
+
+
 ;;
 ;; Fixme: see if the parameter is mutated.  If so, box it.
 ;;

simulator-primitives.rkt

@@ -2,6 +2,7 @@
 (require "simulator-structs.rkt"
          "il-structs.rkt"
          racket/math
+         racket/list
          (for-syntax racket/base))
 
 (provide lookup-primitive set-primitive!)
@@ -133,6 +134,28 @@
                          the-void-value))
 
 
+(define current-continuation-marks   
+  (letrec ([f (case-lambda [(a-machine)
+                            (f a-machine default-continuation-prompt-tag-value)]
+                           [(a-machine tag)
+                            (make-ContinuationMarkSet
+                             (let loop ([frames (machine-control a-machine)])
+                               (cond
+                                 [(empty? frames)
+                                  empty]
+                                 [(eq? tag (frame-tag (first frames)))
+                                  empty]
+                                 [else
+                                  (append (hash-map (frame-marks (first frames))
+                                                    cons)
+                                          (loop (rest frames)))])))])])
+    (make-primitive-proc (lambda args (apply f args))
+                         '(1 2)
+                         'current-continuation-marks)))
+                        
+
+
+
 (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= 
                                                      sub1
                                                      not
@@ -182,6 +205,7 @@
                                                     
                                                      
                                                      symbol?)
-                                      #:constants (null pi e)))
+                                      #:constants (null pi e
+                                                        current-continuation-marks)))
 
 

simulator-structs.rkt

@@ -74,6 +74,34 @@
                              [marks : (HashTable PrimitiveValue PrimitiveValue)])
   #:transparent)
 
+
+(: frame-temps (frame -> (HashTable Symbol PrimitiveValue)))
+(define (frame-temps a-frame)
+  (cond
+    [(CallFrame? a-frame)
+     (CallFrame-temps a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-temps a-frame)]))
+
+
+(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue)))
+(define (frame-marks a-frame)
+  (cond
+    [(CallFrame? a-frame)
+     (CallFrame-marks a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-marks a-frame)]))
+
+(: frame-tag (frame -> (U ContinuationPromptTagValue #f)))
+(define (frame-tag a-frame)
+  (cond
+    [(CallFrame? a-frame)
+     #f]
+    [(PromptFrame? a-frame)
+     (PromptFrame-tag a-frame)]))
+
+
+
 (define-struct: ContinuationPromptTagValue ([name : Symbol])
   #:transparent)
 
@@ -82,6 +110,15 @@
 
 
 
+(define-struct: ContinuationMarkSet ([marks : (Listof (Pairof PrimitiveValue PrimitiveValue))])
+  #:transparent)
+
+
+
+
+
+
+
 (define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))]
                           [vals : (Listof PrimitiveValue)])
   #:transparent

simulator.rkt

@@ -457,22 +457,6 @@
                            (ensure-primitive-value v))
                 'ok))]))
 
-(: frame-temps (frame -> (HashTable Symbol PrimitiveValue)))
-(define (frame-temps a-frame)
-  (cond
-    [(CallFrame? a-frame)
-     (CallFrame-temps a-frame)]
-    [(PromptFrame? a-frame)
-     (PromptFrame-temps a-frame)]))
-
-
-(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue)))
-(define (frame-marks a-frame)
-  (cond
-    [(CallFrame? a-frame)
-     (CallFrame-marks a-frame)]
-    [(PromptFrame? a-frame)
-     (PromptFrame-marks a-frame)]))
 
 
 (: step-assign-primitive-operation! (machine AssignPrimOpStatement -> 'ok))

test-compiler.rkt

@@ -1082,6 +1082,11 @@
 
 
 
+(test '(with-continuation-mark 'name "danny" 
+         (continuation-mark-set->list (current-continuation-marks)))
+      '("danny"))
+
+
 #;(test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt")))
 

test-parse.rkt

@@ -479,3 +479,11 @@
            'lamEntry1))
          (make-App (make-ToplevelRef 0 3) '())
          (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1)))))))
+
+
+
+(test (parse '(with-continuation-mark x y z))
+      (make-Top (make-Prefix '(x y z))
+                (make-WithContMark (make-ToplevelRef 0 0)
+                                   (make-ToplevelRef 0 1)
+                                   (make-ToplevelRef 0 2))))