diff --git a/parse.rkt b/parse.rkt index 4ddfa3f..767575b 100644 --- a/parse.rkt +++ b/parse.rkt @@ -146,6 +146,12 @@ (definition-variable exp) (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) @@ -271,6 +277,11 @@ [(set!? exp) (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) @@ -334,6 +345,11 @@ [(set!? exp) (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) @@ -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. ;; diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 89e3b9e..311e8a1 100644 --- a/simulator-primitives.rkt +++ b/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))) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 91a4e37..a3d8db2 100644 --- a/simulator-structs.rkt +++ b/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 diff --git a/simulator.rkt b/simulator.rkt index 9179dde..f83cd25 100644 --- a/simulator.rkt +++ b/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)) diff --git a/test-compiler.rkt b/test-compiler.rkt index ec9e1c6..a339338 100644 --- a/test-compiler.rkt +++ b/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"))) diff --git a/test-parse.rkt b/test-parse.rkt index da6c84b..bf08447 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -478,4 +478,12 @@ '(0) 'lamEntry1)) (make-App (make-ToplevelRef 0 3) '()) - (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1))))))) \ No newline at end of file + (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)))) \ No newline at end of file