testandbranch

il-structs.rkt

@@ -91,7 +91,7 @@
                                   [rands : (Listof (U Label Reg Const))])
   #:transparent)
 (define-struct: TestAndBranchStatement ([op : PrimitiveTest]
-                                        [register-rand : AtomicRegisterSymbol]
+                                        [register : AtomicRegisterSymbol]
                                         [label : Symbol])
   #:transparent)
 

simulator.rkt

@@ -1,6 +1,9 @@
 #lang typed/racket/base
 
 ;; An evaluator for the intermediate language, so I can do experiments.
+;;
+;; For example, I'll need to be able to count the number of statements executed by an evaluation.
+;; I also need to do things like count pushes and pops.  Basically, low-level benchmarking.
 
 (require "il-structs.rkt"
          "simulator-structs.rkt"
@@ -44,7 +47,7 @@
            [(GotoStatement? i)
             (step-goto m i)]
            [(TestAndBranchStatement? i)
-            (error 'step)]
+            (step-test-and-branch m i)]
            [(PopEnvironment? i)
             (step-pop-environment m i)]
            [(PushEnvironment? i)
@@ -113,7 +116,25 @@
                  (control-pop m)])
                m))
 
+(: step-test-and-branch (machine TestAndBranchStatement -> machine))
+(define (step-test-and-branch m stmt)
+  (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
+         [argval : Any (lookup-atomic-register m (TestAndBranchStatement-register stmt))])
+        (if (cond
+              [(eq? test 'false?)
+               (not argval)]
+              [(eq? test 'primitive-procedure?)
+               (primitive-proc? argval)])
+            (jump m (TestAndBranchStatement-label stmt))
+            m)))
 
+      
+(: lookup-atomic-register (machine AtomicRegisterSymbol -> Any))
+(define (lookup-atomic-register m reg)
+  (cond [(eq? reg 'val)
+         (machine-val m)]
+        [(eq? reg 'proc)
+         (machine-proc m)]))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 

test-simulator.rkt

@@ -2,6 +2,7 @@
 
 (require "il-structs.rkt"
          "simulator-structs.rkt"
+         "simulator-prims.rkt"
          "simulator.rkt")
 
 
@@ -153,4 +154,69 @@
                         ,(make-PopControlFrame)
                         ,(make-PopControlFrame)))])
   (test (machine-control (run m))
-        (list)))
+        (list)))
+
+
+
+
+
+;; TestAndBranch: try the true branch
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))
+                        ,(make-TestAndBranchStatement 'false? 'val 'on-false)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-false
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                        end))])
+  (test (machine-val (run m))
+        'ok))
+;; TestAndBranch: try the false branch
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
+                        ,(make-TestAndBranchStatement 'false? 'val 'on-false)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-false
+                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                        end))])
+  (test (machine-val (run m))
+        'ok))
+;; Test for primitive procedure
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                        end))])
+  (test (machine-val (run m))
+        'ok))
+;; Give a primitive procedure in val
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                        end))])
+  (test (machine-val (run m))
+        'ok))
+;; Give a primitive procedure in proc, but test val
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                        end))])
+  (test (machine-val (run m))
+        'not-a-procedure))
+;; Give a primitive procedure in proc and test proc
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                        end))])
+  (test (machine-val (run m))
+        'a-procedure))