diff --git a/simulator.rkt b/simulator.rkt index fbff60f..2425d85 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -166,9 +166,42 @@ (error 'step-perform "Procedure register doesn't hold a procedure: ~s" a-proc)]))]))) +(: get-target-updater (Target -> (machine SlotValue -> machine))) +(define (get-target-updater t) + (cond + [(eq? t 'proc) + proc-update] + [(eq? t 'val) + val-update] + [(EnvLexicalReference? t) + (lambda: ([m : machine] [v : SlotValue]) + (env-mutate m (EnvLexicalReference-depth t) v))])) + + (: step-assign-primitive-operation (machine AssignPrimOpStatement -> machine)) (define (step-assign-primitive-operation m stmt) - m) + (let: ([op : PrimitiveOperator (AssignPrimOpStatement-op stmt)] + [target-updater : (machine SlotValue -> machine) + (get-target-updater (AssignPrimOpStatement-target stmt))]) + (cond + [(GetCompiledProcedureEntry? op) + (let: ([a-proc : SlotValue (machine-proc m)]) + (cond + [(closure? a-proc) + (target-updater m (closure-label a-proc))] + [else + (error 'get-copmiled-procedure-entry)]))] + + [(MakeCompiledProcedure? op) + m] + [(ApplyPrimitiveProcedure? op) + m] + [(LookupLexicalAddress? op) + m] + [(LookupToplevelAddress? op) + m] + [(GetControlStackLabel? op) + m]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test-simulator.rkt b/test-simulator.rkt index 84a5e29..f7f0ec0 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -288,3 +288,25 @@ +(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-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))))]) + (test (machine-val (run m)) + 'procedure-entry)) + + + +#;(let ([m (new-machine `(,(make-AssignPrimOpStatement (make-MakeCompiledProcedure))))]) + (test ...)) +#;(let ([m (new-machine `(,(make-AssignPrimOpStatement (make-ApplyPrimitiveProcedure))))]) + (test ...)) +#;(let ([m (new-machine `(,(make-AssignPrimOpStatement (make-LookupLexicalAddress))))]) + (test ...)) +#;(let ([m (new-machine `(,(make-AssignPrimOpStatement (make-LookupToplevelAddress))))]) + (test ...)) +#;(let ([m (new-machine `(,(make-AssignPrimOpStatement (make-GetControlStackLabel))))]) + (test ...)) \ No newline at end of file