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)))
+  (with-input-from-port port (vm 'run)))