popframe

simulator-prims.rkt

@@ -0,0 +1,13 @@
+#lang racket/base
+(require "simulator-structs.rkt")
+
+(provide lookup-primitive)
+
+(define (lookup-primitive name)
+  (cond
+    [(eq? name '+)
+     (make-primitive-proc +)]
+    [(eq? name '=)
+     (make-primitive-proc =)]
+    [else
+     (void)]))

simulator-structs.rkt

@@ -20,3 +20,5 @@
   #:transparent)
 
 
+;; Primitive procedure wrapper
+(define-struct: primitive-proc ([f : (Any * -> Any)]))

simulator.rkt

@@ -5,7 +5,12 @@
 (require "il-structs.rkt"
          "simulator-structs.rkt"
          racket/list
-         racket/match)
+         racket/match
+         (for-syntax racket/base))
+
+(require/typed "simulator-prims.rkt"
+               [lookup-primitive (Symbol -> (Any * -> Any))])
+               
 
 (provide new-machine can-step? step)
 
@@ -45,9 +50,10 @@
            [(PushEnvironment? i)
             (step-push-environment m i)]
            [(PushControlFrame? i)
-            (error 'step)]
+            (step-push-control-frame m i)]
            [(PopControlFrame? i)
-            (error 'step)]))))
+            (step-pop-control-frame m i)]))))
+
   
     
 (: step-goto (machine GotoStatement -> machine))
@@ -90,12 +96,22 @@
              (sub1 n))])))
 
 (: step-pop-environment (machine PopEnvironment -> machine))
-(define (step-pop-environment machine stmt)
+(define (step-pop-environment m stmt)
-  (env-pop machine
+  (env-pop m
            (PopEnvironment-n stmt)
            (PopEnvironment-skip stmt)))
 
 
+(: step-push-control-frame (machine PushControlFrame -> machine))
+(define (step-push-control-frame m stmt)
+  (control-push m (PushControlFrame-label stmt)))
+
+(: step-pop-control-frame (machine PopControlFrame -> machine))
+(define (step-pop-control-frame m stmt)
+  (let-values: ([([m : machine]
+                  [l : Symbol])
+                 (control-pop m)])
+               m))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -197,8 +213,8 @@
      (make-machine val proc env (cons (make-frame l) control) pc text)]))
 
 
-(: control-pop (machine Symbol -> (values machine Symbol)))
+(: control-pop (machine -> (values machine Symbol)))
-(define (control-pop m l)
+(define (control-pop m)
   (match m
     [(struct machine (val proc env control pc text))
      (values (make-machine val proc env (rest control) pc text)
@@ -226,4 +242,6 @@
           [(eq? (vector-ref vec i) x)
            i]
           [else
-           (loop (add1 i))])))
+           (loop (add1 i))])))
+
+

test-simulator.rkt

@@ -118,3 +118,39 @@
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const "louie"))
                         ,(make-PopEnvironment 2 1)))])
   (test (machine-env (run m)) '("hewie")))
+
+
+
+;; PushControl
+(let ([m (new-machine `(foo 
+                        ,(make-PushControlFrame 'foo)
+                        bar
+                        ,(make-PushControlFrame 'bar)
+                        baz
+                        ))])
+  (test (machine-control (run m))
+        (list (make-frame 'bar)
+              (make-frame 'foo))))
+
+
+
+;; PopControl
+(let ([m (new-machine `(foo 
+                        ,(make-PushControlFrame 'foo)
+                        bar
+                        ,(make-PushControlFrame 'bar)
+                        baz
+                        ,(make-PopControlFrame)
+                        ))])
+  (test (machine-control (run m))
+        (list (make-frame 'foo))))
+
+(let ([m (new-machine `(foo 
+                        ,(make-PushControlFrame 'foo)
+                        bar
+                        ,(make-PushControlFrame 'bar)
+                        baz
+                        ,(make-PopControlFrame)
+                        ,(make-PopControlFrame)))])
+  (test (machine-control (run m))
+        (list)))