install closure values.
This commit is contained in:
parent
6bf17b7d0b
commit
865181ddc4
|
@ -158,7 +158,15 @@
|
||||||
(make-toplevel (map lookup-primitive
|
(make-toplevel (map lookup-primitive
|
||||||
(ExtendEnvironment/Prefix!-names op))))]
|
(ExtendEnvironment/Prefix!-names op))))]
|
||||||
[(InstallClosureValues!? 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))
|
[(struct machine (val proc env control pc text))
|
||||||
(make-machine val proc (cons v 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))
|
(: env-ref (machine Natural -> Any))
|
||||||
(define (env-ref m i)
|
(define (env-ref m i)
|
||||||
(match m
|
(match m
|
||||||
|
|
|
@ -270,3 +270,18 @@
|
||||||
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
|
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
|
||||||
(void (run m)))
|
(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)))
|
Loading…
Reference in New Issue
Block a user