diff --git a/compile.rkt b/compile.rkt index 99d508c..d21a425 100644 --- a/compile.rkt +++ b/compile.rkt @@ -52,7 +52,9 @@ [(LetVoid? exp) (compile-let-void exp cenv target linkage)] [(InstallValue? exp) - (compile-install-value exp cenv target linkage)])) + (compile-install-value exp cenv target linkage)] + [(BoxEnv? exp) + (compile-box-environment-value exp cenv target linkage)])) @@ -513,6 +515,13 @@ +(: compile-box-environment-value (BoxEnv Natural Target Linkage -> InstructionSequence)) +(define (compile-box-environment-value exp cenv target linkage) + (append-instruction-sequences + (make-instruction-sequence + `(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) + (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))))) + (compile (BoxEnv-body exp) cenv target linkage))) (: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) diff --git a/il-structs.rkt b/il-structs.rkt index b045eb1..a368647 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -117,6 +117,7 @@ MakeCompiledProcedure ApplyPrimitiveProcedure GetControlStackLabel + MakeBoxedEnvironmentValue CaptureEnvironment CaptureControl @@ -150,6 +151,10 @@ (define-struct: GetControlStackLabel () #:transparent) +(define-struct: MakeBoxedEnvironmentValue ([depth : Natural]) + #:transparent) + + ;; Capture the current environment, skipping skip frames. (define-struct: CaptureEnvironment ([skip : Natural])) diff --git a/simulator.rkt b/simulator.rkt index d2756ad..c67b30f 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -314,7 +314,11 @@ (CaptureEnvironment-skip op))))] [(CaptureControl? op) (target-updater! m (make-CapturedControl (drop (machine-control m) - (CaptureControl-skip op))))]))) + (CaptureControl-skip op))))] + [(MakeBoxedEnvironmentValue? op) + (target-updater! m (box (ensure-primitive-value + (env-ref m (MakeBoxedEnvironmentValue-depth op)))))]))) + diff --git a/test-compiler.rkt b/test-compiler.rkt index 0279dae..8528561 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -647,6 +647,22 @@ +(test '(begin (define counter 0) + (set! counter (add1 counter)) + counter) + 1) + +(test '(begin (define x 16) + (define (f x) + (set! x (add1 x)) + x) + (list (f 3) + (f 4) + x)) + (list 4 5 16)) + + + #;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt")))