init git

scmvm/vm.scm

@@ -0,0 +1,138 @@
+(define-module (scmvm vm)
+  #:use-module ((scheme base)
+                #:select (read-u8 read-bytevector))
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-26)
+  #:export (make-vm run-vm vm-memory-ref vm-memory-set!))
+
+;;; Data Structures
+(define *stack-size* 1000)
+(define *memory-size* 2048)
+
+(define* (make-stack #:optional (stack-size *stack-size*))
+  "Make a new stack, optionally setting the size"
+  (define the-stack (make-vector stack-size))
+  (define top 0)
+  (lambda (x)
+    (case x
+      [(push)
+       (lambda (v)
+         (if (>= top stack-size)
+             (error "stack overflow")
+             (begin
+               (vector-set! the-stack top v)
+               (set! top (1+ top)))))]
+      [(pop)
+       (lambda ()
+         (if (zero? top)
+             (error "pop empty stack")
+             (begin
+               (set! top (1- top))
+               (vector-ref the-stack top))))]
+      [(peek)
+       (lambda ()
+         (if (zero? top)
+             (error "peek empty stack")
+             (vector-ref the-stack (1- top))))]
+      [(ref)
+       (lambda (k)
+         (vector-ref the-stack k))]
+      [else (error "stack dispatch unknown value")])))
+
+(define (push stack v)
+  ((stack 'push) v))
+
+(define (pop stack)
+  ((stack 'pop)))
+
+(define (peek stack)
+  ((stack 'peek)))
+
+(define (stack-ref stack k)
+  ((stack 'ref) k))
+
+(define* (make-ram #:optional (memory-size *memory-size*))
+  (make-vector memory-size))
+
+(define (ram-ref ram k)
+  (vector-ref ram k))
+
+(define (ram-set! ram k v)
+  (vector-set! ram k v))
+
+;;; IO
+(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))))
+
+;;; Program execution
+(define *opcodes*
+  '((#x01 . push)
+    (#x02 . pop)
+    (#x03 . store)
+    (#x04 . load)
+    (#x05 . +)
+    (#x06 . -)
+    (#x07 . and)
+    (#x08 . or)
+    (#x09 . nand)
+    (#x0a . nor)
+    (#x0b . xor)
+    (#x0c . if)
+    (#x0d . call)
+    (#x0e . return)))
+
+(define op-lookup (cute assq-ref *opcodes* <>))
+
+(define (binop-lookup op)
+  (case (op-lookup op)
+    [(+) +]
+    [(-) -]
+    [(and) logand]
+    [(or) logior]
+    [(nand) (compose lognot logand)]
+    [(nor) (compose lognot logior)]
+    [(xor) logxor]))
+
+(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)))
+  (define ret-stack (if stack-size (make-stack stack-size) (make-stack)))
+  (define ram (if memory-size (make-ram memory-size) (make-ram)))
+  (define (fetch-and-execute)
+    (define op (read-u8))
+    (unless (eof-object? op)
+      (case (op-lookup op)
+        [(push)
+         (push data-stack (read-word))]
+        [(pop)
+         (pop data-stack)]
+        [(store)
+         (let ([addr (read-word)]
+               [v (pop data-stack)])
+           (ram-set! ram addr v))]
+        [(load)
+         (let* ([addr (read-word)]
+                [v (ram-ref ram addr)])
+           (push data-stack v))]
+        [(+ - and or nand nor xor)
+         (let ([v2 (pop data-stack)]
+               [v1 (pop data-stack)])
+           (push data-stack ((binop-lookup op) v1 v2)))])
+      (fetch-and-execute)))
+  (lambda (x)
+    (case x
+      [(run) fetch-and-execute]
+      [(vm-memory-ref) (cute ram-ref ram <>)]
+      [(vm-memory-set!) (lambda (k v) (ram-set! ram k v))])))
+
+(define (vm-memory-ref vm k)
+  ((vm 'vm-memory-ref) k))
+
+(define (vm-memory-set vm k v)
+  ((vm 'vm-memory-set!) k v))
+
+(define (run-program vm port)
+  "Read and execute instructions read from port on VM"
+  (with-input-from-port port (vm 'run)))

tests.scm

@@ -0,0 +1,21 @@
+(use-modules (d- test))
+
+
+;;; VM tests
+(use-modules (scmvm vm)
+             (rnrs bytevectors)
+             (rnrs io ports))
+
+(define adder-program
+  #vu8(#x01 1 0 0 0 ; Push value "1"
+       #x01 2 0 0 0 ; Push value "2"
+       #x05         ; Perform "+"
+       #x03 1 0 0 0 ; Store the value to memory address 1
+       ))
+
+(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)
+    (assert-equal 3 (vm-memory-ref my-vm 1))))