diff --git a/simulator.rkt b/simulator.rkt index 539638f..43f4537 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -158,7 +158,15 @@ (make-toplevel (map lookup-primitive (ExtendEnvironment/Prefix!-names op))))] [(InstallClosureValues!? op) - (error 'step-perform)]))) + (let: ([a-proc : SlotValue (machine-proc m)]) + (cond + [(closure? a-proc) + (env-push-many m + (closure-vals a-proc))] + [else + (error 'step-perform "Procedure register doesn't hold a procedure: ~s" + a-proc)]))]))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -258,6 +266,13 @@ [(struct machine (val proc env control pc text)) (make-machine val proc (cons v env) control pc text)])) +(: env-push-many (machine (Listof SlotValue) -> machine)) +(define (env-push-many m vs) + (match m + [(struct machine (val proc env control pc text)) + (make-machine val proc (append vs env) control pc text)])) + + (: env-ref (machine Natural -> Any)) (define (env-ref m i) (match m diff --git a/test-simulator.rkt b/test-simulator.rkt index 2358fc7..fc17eac 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -270,3 +270,18 @@ ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))]) (void (run m))) + + +;; install-closure-values +(let ([m + (make-machine (make-undefined) (make-closure 'procedure-entry + (list 1 2 3)) + (list true false) ;; existing environment holds true, false + '() + 0 + (list->vector `(,(make-PerformStatement (make-InstallClosureValues!)) + procedure-entry + )))]) + (test (machine-env (run m)) + ;; Check that the environment has installed the expected closure values. + (list 1 2 3 true false))) \ No newline at end of file