testing goto in the simulator

il-structs.rkt

@@ -11,6 +11,7 @@
 (define-type AtomicRegisterSymbol (U 'val 'proc))
 (define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol))
 
+(define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

simulator-structs.rkt

@@ -12,9 +12,11 @@
 
                          [pc : Natural]                  ;; program counter
                          [text : (Vectorof Statement)]   ;; text of the program
-                         ))
+                         )
+  #:transparent)
 
 
-(define-struct: frame ([return : Symbol]))
+(define-struct: frame ([return : Symbol])
+  #:transparent)
 
 

simulator.rkt

@@ -16,11 +16,14 @@
 
 
 (: can-step? (machine -> Boolean))
+;; Produces true if we can make a further step in the simulation.
 (define (can-step? m)
-  #t)
+  (< (machine-pc m)
+     (vector-length (machine-text m))))
 
 
 (: step (machine -> machine))
+;; Take one simulation step.
 (define (step m)
   (let: ([i : Statement (current-instruction m)])
         (cond
@@ -33,7 +36,7 @@
           [(PerformStatement? i)
            (error 'step)]
           [(GotoStatement? i)
-           (error 'step)]
+           (step-goto m i)]
           [(TestAndBranchStatement? i)
            (error 'step)]
           [(PopEnvironment? i)
@@ -46,8 +49,33 @@
            (error 'step)])))
 
     
+(: step-goto (machine GotoStatement -> machine))
+(define (step-goto m a-goto)
+  (let: ([t : (U Label Reg) (GotoStatement-target a-goto)])
+        (cond [(Label? t)
+               (jump m (Label-name t))]
+              [(Reg? t)
+               (let: ([reg : RegisterSymbol (Reg-name t)])
+                     (cond [(AtomicRegisterSymbol? reg)
+                            (cond [(eq? reg 'val)
+                                   (jump m (ensure-symbol (machine-val m)))]
+                                  [(eq? reg 'proc)
+                                   (jump m (ensure-symbol (machine-proc m)))])]
+                           [else
+                            (error 'step-goto "Register '~s is supposed to be either 'val or 'proc"
+                                   reg)]))])))
 
 
+(: ensure-symbol (Any -> Symbol))
+;; Make sure the value is a symbol.
+(define (ensure-symbol v)
+  (cond
+    [(symbol? v)
+     v]
+    [else
+     (error 'ensure-symbol)]))
+  
+  
 
 (: current-instruction (machine -> Statement))
 (define (current-instruction m)
@@ -128,10 +156,11 @@
 
 
 (: jump (machine Symbol -> machine))
+;; Jumps directly to the instruction right after the given label.
 (define (jump m l)
   (match m
     [(struct machine (val proc env control pc text))
-     (make-machine val proc env control (vector-find text l) text)]))
+     (make-machine val proc env control (add1 (vector-find text l)) text)]))
 
 
 (: vector-find (All (A) (Vectorof A) A -> Natural))

test-simulator.rkt

@@ -0,0 +1,34 @@
+#lang racket
+
+(require "il-structs.rkt"
+         "simulator-structs.rkt"
+         "simulator.rkt")
+
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ actual exp)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (let ([results actual])
+           (unless (equal? actual exp)
+             (raise-syntax-error #f (format "Expected ~s, got ~s" exp results)
+                                 #'stx)))))]))
+
+
+;; take n steps in evaluating the machine.
+(define (step-n m n)
+  (cond
+    [(= n 0)
+     m]
+    [else
+     (step-n (step m) (sub1 n))]))
+
+
+(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello))))])
+  (test (machine-pc (step-n m 0)) 0)
+  (test (machine-pc (step-n m 1)) 1)
+  (test (machine-pc (step-n m 2)) 2)
+  (test (machine-pc (step-n m 3)) 1)
+  (test (machine-pc (step-n m 4)) 2)
+  (test (machine-pc (step-n m 5)) 1))