Further augment vm, create test to perform fibonocci sequence test

scmvm/vm.scm

@@ -34,6 +34,14 @@
          (if (zero? top)
              (error "peek empty stack")
              (vector-ref the-stack (1- top))))]
+      [(swap)
+       (lambda ()
+         (if (< (vector-length the-stack) 2)
+             (error "no value to swap")
+             (let ([a (vector-ref the-stack (- top 2))]
+                   [b (vector-ref the-stack (- top 1))])
+               (vector-set! the-stack (- top 2) b)
+               (vector-set! the-stack (- top 1) a))))]
       [(ref)
        (lambda (k)
          (vector-ref the-stack k))]
@@ -48,6 +56,9 @@
 (define (peek stack)
   ((stack 'peek)))
 
+(define (swap stack)
+  ((stack 'swap)))
+
 (define (stack-ref stack k)
   ((stack 'ref) k))
 
@@ -64,7 +75,7 @@
 (define (read-word)
   "Read the next 32-bit value from (current-input-port)"
   (let ([bv (read-bytevector 4)])
-    (bytevector-u32-ref bv 0 (native-endianness))))
+    (bytevector-s32-ref bv 0 (native-endianness))))
 
 ;;; Program execution
 (define *opcodes*
@@ -81,7 +92,15 @@
     (#x0b . xor)
     (#x0c . if)
     (#x0d . call)
-    (#x0e . return)))
+    (#x0e . return)
+    (#x0f . >R)
+    (#x10 . R>)
+    (#x11 . =)
+    (#x12 . >)
+    (#x13 . <)
+    (#x14 . dup)
+    (#x15 . swap)
+    (#x16 . jmp)))
 
 (define op-lookup (cute assq-ref *opcodes* <>))
 
@@ -95,6 +114,18 @@
     [(nor) (compose lognot logior)]
     [(xor) logxor]))
 
+(define (relop-lookup op)
+  (case (op-lookup op)
+    [(>) >]
+    [(<) <]
+    [(=) =]))
+
+(define (jump addr)
+  (seek (current-input-port) addr SEEK_SET))
+
+(define (tell)
+  (ftell (current-input-port)))
+
 (define* (make-vm #:key stack-size memory-size)
   "Create a fresh VM, with optional stack and memory sizes"
   (define data-stack (if stack-size (make-stack stack-size) (make-stack)))
@@ -119,7 +150,33 @@
         [(+ - and or nand nor xor)
          (let ([v2 (pop data-stack)]
                [v1 (pop data-stack)])
-           (push data-stack ((binop-lookup op) v1 v2)))])
+           (push data-stack ((binop-lookup op) v1 v2)))]
+        [(= > <)
+         (let ([v2 (pop data-stack)]
+               [v1 (pop data-stack)])
+           (if ((relop-lookup op) v1 v2)
+               (push data-stack 1)
+               (push data-stack 0)))]
+        [(if)
+         (let ([addr (read-word)])
+           (when (zero? (peek data-stack))
+             (jump addr)))]
+        [(call)
+         (let ([addr (read-word)])
+           (push ret-stack (tell))
+           (jump addr))]
+        [(return)
+         (jump (pop ret-stack))]
+        [(>R)
+         (push ret-stack (pop data-stack))]
+        [(R>)
+         (push data-stack (pop ret-stack))]
+        [(dup)
+         (push data-stack (peek data-stack))]
+        [(swap)
+         (swap data-stack)]
+        [(jmp)
+         (jump (read-word))])
       (fetch-and-execute)))
   (lambda (x)
     (case x
@@ -128,11 +185,13 @@
       [(vm-memory-set!) (lambda (k v) (ram-set! ram k v))])))
 
 (define (vm-memory-ref vm k)
+  "Externally access VM memory at k"
   ((vm 'vm-memory-ref) k))
 
-(define (vm-memory-set vm k v)
+(define (vm-memory-set! vm k v)
+  "Externally set VM memory at k to v"
   ((vm 'vm-memory-set!) k v))
 
-(define (run-program vm port)
+(define (run-vm vm port)
   "Read and execute instructions read from port on VM"
   (with-input-from-port port (vm 'run))) 

tests.scm

@@ -13,9 +13,54 @@
        #x03 1 0 0 0 ; Store the value to memory address 1
        ))
 
+(define fib-program
+  #vu8(#x04 1  0 0 0 ; 0  load "n" from memory address 0x01
+       #x0d 15 0 0 0 ; 5  call fib procedure
+       #x16 83 0 0 0 ; 10 jump to cleanup
+       ;; "fib" procedure
+       #x14          ; 15 duplicate n
+       #x01 0  0 0 0 ; 16 push 0
+       #x11          ; 21 test equality
+       #x0c 35 0 0 0 ; 22 if
+       #x02          ; 27 pop tested value
+       #x02          ; 28 pop n
+       #x01 0  0 0 0 ; 29 push '0'
+       #x0e          ; 31 return
+       #x02          ; 35 pop tested value
+       #x14          ; 36 duplicate n
+       #x01 1  0 0 0 ; 37 push 1
+       #x11          ; 42 test equality
+       #x0c 56 0 0 0 ; 43 if
+       #x02          ; 48 pop tested value
+       #x02          ; 49 pop n
+       #x01 1  0 0 0 ; 50 push '1'
+       #x0e          ; 55 return
+       #x02          ; 56 pop tested value
+       ;; recursively calculate fib (n - 1)
+       #x01 1  0 0 0 ; 57 push 1
+       #x06          ; 62 (n - 1)
+       #x14          ; 63 duplicate (n - 1) as an arg
+       #x0d 15 0 0 0 ; 64 call fib
+       ;; recursively calculate fib (n - 2)
+       #x15          ; 69 swap n - 1 back atop stack
+       #x01 1  0 0 0 ; 70 push 1
+       #x06          ; 75 (n - 2)
+       #x0d 15 0 0 0 ; 76 call fib
+       #x05          ; 81 (fib(n - 1) + fib (n - 2))
+       #x0e          ; 82 return
+       ;; cleanup
+       #x03 1  0 0 0 ; 83 store fib(n) to memory address 0x01
+       ))
+
 (define-test-suite "VM"
   (define-test "adder"
     (define my-vm (make-vm))
     (define my-program (open-bytevector-input-port adder-program))
-    (run-program my-vm my-program)
+    (run-vm my-vm my-program)
-    (assert-equal 3 (vm-memory-ref my-vm 1))))
+    (assert-equal 3 (vm-memory-ref my-vm 1)))
+  (define-test "fib"
+    (define my-vm (make-vm))
+    (vm-memory-set! my-vm 1 6)
+    (define my-program (open-bytevector-input-port fib-program))
+    (run-vm my-vm my-program)
+    (assert-equal 8 (vm-memory-ref my-vm 1))))