A virtual machine implements a computer in software.

Task[edit]
Write a virtual machine interpreter. This interpreter should be able to run virtual
assembly language programs created via the task. This is a
byte-coded, 32-bit word stack based virtual machine.

The program should read input from a file and/or stdin, and write output to a file and/or
stdout.

Input format:

Given the following program:

count = 1;
while (count < 10) {
    print("count is: ", count, "\n");
    count = count + 1;
}

The output from the Code generator is a virtual assembly code program:



 Output from gen, input to VM



Datasize: 1 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (43) 65
   26 push  0
   31 prts
   32 fetch [0]
   37 prti
   38 push  1
   43 prts
   44 fetch [0]
   49 push  1
   54 add
   55 store [0]
   60 jmp    (-51) 10
   65 halt

The first line of the input specifies the datasize required and the number of constant
strings, in the order that they are reference via the code.

The data can be stored in a separate array, or the data can be stored at the beginning of
the stack. Data is addressed starting at 0. If there are 3 variables, the 3rd one if
referenced at address 2.

If there are one or more constant strings, they come next. The code refers to these
strings by their index. The index starts at 0. So if there are 3 strings, and the code
wants to reference the 3rd string, 2 will be used.

Next comes the actual virtual assembly code. The first number is the code address of that
instruction. After that is the instruction mnemonic, followed by optional operands,
depending on the instruction.

Registers:

sp:

   the stack pointer - points to the next top of stack.  The stack is a 32-bit integer
   array.

pc:

   the program counter - points to the current instruction to be performed.  The code is an
   array of bytes.

Data:

   data
   string pool

Instructions:

Each instruction is one byte. The following instructions also have a 32-bit integer
operand:

fetch [index]

where index is an index into the data array.

store [index]

where index is an index into the data array.

push n

where value is a 32-bit integer that will be pushed onto the stack.

jmp (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

jz (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

The following instructions do not have an operand. They perform their operation directly
against the stack:

For the following instructions, the operation is performed against the top two entries in
the stack:

add
sub
mul
div
mod
lt
gt
le
ge
eq
ne
and
or

For the following instructions, the operation is performed against the top entry in the
stack:

neg
not

Print the word at stack top as a character.

prtc

Print the word at stack top as an integer.

prti

Stack top points to an index into the string pool. Print that entry.

prts

Unconditional stop.

halt

 A simple example virtual machine

def run_vm(data_size)
    int stack[data_size + 1000]
    set stack[0..data_size - 1] to 0
    int pc = 0
    while True:
        op = code[pc]
        pc += 1
 
        if op == FETCH:
            stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
            pc += word_size
        elif op == STORE:
            stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
            pc += word_size
        elif op == PUSH:
            stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
            pc += word_size
        elif op == ADD:   stack[-2] += stack[-1]; stack.pop()
        elif op == SUB:   stack[-2] -= stack[-1]; stack.pop()
        elif op == MUL:   stack[-2] *= stack[-1]; stack.pop()
        elif op == DIV:   stack[-2] /= stack[-1]; stack.pop()
        elif op == MOD:   stack[-2] %= stack[-1]; stack.pop()
        elif op == LT:    stack[-2] = stack[-2] <  stack[-1]; stack.pop()
        elif op == GT:    stack[-2] = stack[-2] >  stack[-1]; stack.pop()
        elif op == LE:    stack[-2] = stack[-2] <= stack[-1]; stack.pop()
        elif op == GE:    stack[-2] = stack[-2] >= stack[-1]; stack.pop()
        elif op == EQ:    stack[-2] = stack[-2] == stack[-1]; stack.pop()
        elif op == NE:    stack[-2] = stack[-2] != stack[-1]; stack.pop()
        elif op == AND:   stack[-2] = stack[-2] and stack[-1]; stack.pop()
        elif op == OR:    stack[-2] = stack[-2] or  stack[-1]; stack.pop()
        elif op == NEG:   stack[-1] = -stack[-1]
        elif op == NOT:   stack[-1] = not stack[-1]
        elif op == JMP:   pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == JZ:    if stack.pop() then pc += word_size else pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == PRTC:  print stack[-1] as a character; stack.pop()
        elif op == PRTS:  print the constant string referred to by stack[-1]; stack.pop()
        elif op == PRTI:  print stack[-1] as an integer; stack.pop()
        elif op == HALT:  break
 Additional examples
Your solution should pass all the test cases above and the additional tests found Here.

Reference
The C and Python versions can be considered reference implementations.

Related Tasks
 Lexical Analyzer task
 Syntax Analyzer task
 Code Generator task
 AST Interpreter task

#lang typed/racket
;;;
;;; The Rosetta Code Virtual Machine, in Typed Racket.
;;;
;;; Migrated from the Common Lisp.
;;;
 
;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(: executable-memory-size Positive-Fixnum)
(define executable-memory-size 65536)
 
;;; Similarly, I am going to have fixed size data and stack memory.
(: data-memory-size Positive-Fixnum)
(define data-memory-size 2048)
(: stack-memory-size Positive-Fixnum)
(define stack-memory-size 2048)
 
;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(define-type Word Nonnegative-Fixnum)
(define-type Register (Boxof Word))
(define-type Executable-Memory (Mutable-Vectorof Byte))
(define-type Data-Memory (Mutable-Vectorof Word))
(define-type Stack-Memory (Mutable-Vectorof Word))
 
(define re-blank-line #px"^\\s*$")
(define re-parse-instr-1 #px"^\\s*(\\d+)\\s*(.*\\S)")
(define re-parse-instr-2 #px"(?i:^(\\S+)\\s*(.*))")
(define re-parse-instr-3 #px"^[[(]?([0-9-]+)")
(define re-header
  #px"(?i:^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+))")
(define re-leading-spaces #px"^\\s*")
 
(define opcode-names
  '("halt"
    "add"
    "sub"
    "mul"
    "div"
    "mod"
    "lt"
    "gt"
    "le"
    "ge"
    "eq"
    "ne"
    "and"
    "or"
    "neg"
    "not"
    "prtc"
    "prti"
    "prts"
    "fetch"
    "store"
    "push"
    "jmp"
    "jz"))
 
(: blank-line? (String -> Boolean))
(define (blank-line? s)
  (not (not (regexp-match re-blank-line s))))
 
(: opcode-from-name (String -> Byte))
(define (opcode-from-name s)
  (let ((i (index-of opcode-names s)))
    (assert i)
    (cast i Byte)))
 
(: create-executable-memory (-> Executable-Memory))
(define (create-executable-memory)
  (make-vector executable-memory-size (opcode-from-name "halt")))
 
(: create-data-memory (-> Data-Memory))
(define (create-data-memory)
  (make-vector data-memory-size 0))
 
(: create-stack-memory (-> Stack-Memory))
(define (create-stack-memory)
  (make-vector stack-memory-size 0))
 
(: create-register (-> Register))
(define (create-register)
  (box 0))
 
(struct machine
  ((sp : Register)   ; Stack pointer.
   (ip : Register)   ; Instruction pointer (that is, program counter).
   (code : Executable-Memory)
   (data : Data-Memory)
   (stack : Stack-Memory)
   (strings : (Immutable-Vectorof String))
   (output : Output-Port))
  #:type-name Machine
  #:constructor-name %make-machine)
 
(: make-machine ((Immutable-Vectorof String) Output-Port -> Machine))
(define (make-machine strings outf)
  (%make-machine (create-register)
                 (create-register)
                 (create-executable-memory)
                 (create-data-memory)
                 (create-stack-memory)
                 strings
                 outf))
 
(define-type Instruction-Data (List Word Byte (U False Word)))
 
(: insert-instruction (Executable-Memory Instruction-Data -> Void))
(define (insert-instruction memory instr)
  (void
   (match instr
     ((list address opcode arg)
      (let ((instr-size (if arg 5 1)))
        (unless (<= (+ address instr-size) executable-memory-size)
          (raise-user-error
           "the VM's executable memory size is exceeded"))
        (vector-set! memory address opcode)
        (when arg
          ;; Big-endian order.
          (vector-set! memory (+ address 1)
                       (bitwise-and (arithmetic-shift arg -24) #xFF))
          (vector-set! memory (+ address 2)
                       (bitwise-and (arithmetic-shift arg -16) #xFF))
          (vector-set! memory (+ address 3)
                       (bitwise-and (arithmetic-shift arg -8) #xFF))
          (vector-set! memory (+ address 4)
                       (bitwise-and arg #xFF))))))))
 
(: load-executable-memory (Executable-Memory
                           (Listof Instruction-Data) ->
                           Void))
(define (load-executable-memory memory instr-lst)
  (let loop ((p instr-lst))
    (if (null? p)
        (void)
        (let ((instr (car p)))
          (insert-instruction memory (car p))
          (loop (cdr p))))))
 
(: number->word (Number -> Word))
(define (number->word n)
  (cast (bitwise-and (cast n Integer) #xFFFFFFFF) Word))
 
(: string->word (String -> Word))
(define (string->word s)
  (let ((n (string->number s)))
    (assert (number? n))
    (number->word n)))
 
(: parse-instruction (String -> (U False Instruction-Data)))
(define (parse-instruction s)
  (and (not (blank-line? s))
       (let* ((strings (cast (regexp-match re-parse-instr-1 s)
                             (Listof String)))
              (address (cast (string->number (second strings))
                             Word))
              (split (cast (regexp-match re-parse-instr-2
                                         (third strings))
                           (Listof String)))
              (opcode-name (string-downcase (second split)))
              (opcode (opcode-from-name opcode-name))
              (arguments (third split))
              (has-arg? (match opcode-name
                          ((or "fetch" "store" "push" "jmp" "jz") #t)
                          (_ #f))))
         (if has-arg?
             (let* ((argstr-lst
                     (cast (regexp-match re-parse-instr-3 arguments)
                           (Listof String)))
                    (argstr (second argstr-lst))
                    (arg (string->word argstr)))
               `(,address ,opcode ,arg))
             `(,address ,opcode #f)))))
 
(: read-instructions (Input-Port -> (Listof Instruction-Data)))
(define (read-instructions inpf)
  (let loop ((line (read-line inpf))
             (lst (cast '() (Listof Instruction-Data))))
    (if (eof-object? line)
        (reverse lst)
        (let ((instr (parse-instruction line)))
          (loop (read-line inpf)
                (if instr
                    (cons instr lst)
                    lst))))))
 
(: read-datasize-and-strings-count (Input-Port -> (Values Word Word)))
(define (read-datasize-and-strings-count inpf)
  (let ((line (read-line inpf)))
    (unless (string? line)
      (raise-user-error "empty input"))
    ;; This is a permissive implementation.
    (let* ((strings (cast (regexp-match re-header line)
                          (Listof String)))
           (datasize (string->word (second strings)))
           (strings-count (string->word (third strings))))
      (values datasize strings-count))))
 
(: parse-string-literal (String -> String))
(define (parse-string-literal s)
  ;; This is a permissive implementation, but only in that it skips
  ;; any leading space. It does not check carefully for outright
  ;; mistakes.
  (let* ((s (regexp-replace re-leading-spaces s ""))
         (quote-mark (string-ref s 0)))
    (let loop ((i 1)
               (lst (cast '() (Listof Char))))
      (if (char=? (string-ref s i) quote-mark)
          (list->string (reverse lst))
          (let ((c (string-ref s i)))
            (if (char=? c #\\)
                (let ((c0 (match (string-ref s (+ i 1))
                            (#\n #\newline)
                            (c1 c1))))
                  (loop (+ i 2) (cons c0 lst)))
                (loop (+ i 1) (cons c lst))))))))
 
(: read-string-literals (Input-Port Word -> (Listof String)))
(define (read-string-literals inpf strings-count)
  (for/list ((i (in-range strings-count)))
    (let ((line (read-line inpf)))
      (begin (assert (string? line))
             (parse-string-literal line)))))
 
(: open-inpf (String -> Input-Port))
(define (open-inpf inpf-filename)
  (if (string=? inpf-filename "-")
      (current-input-port)
      (open-input-file inpf-filename)))
 
(: open-outf (String -> Output-Port))
(define (open-outf outf-filename)
  (if (string=? outf-filename "-")
      (current-output-port)
      (open-output-file outf-filename #:exists 'truncate)))
 
(: word-signbit? (Word -> Boolean))
(define (word-signbit? x)
  ;; True if and only if the sign bit is set.
  (not (zero? (bitwise-and x #x80000000))))
 
(: word-add (Word Word -> Word))
(define (word-add x y)
  ;; Addition with overflow freely allowed.
  (cast (bitwise-and (+ x y) #xFFFFFFFF) Word))
 
(: word-neg (Word -> Word))
(define (word-neg x)
  ;; The two's complement.
  (word-add (cast (bitwise-xor x #xFFFFFFFF) Word) 1))
 
(: word-sub (Word Word -> Word))
(define (word-sub x y)
  ;; Subtraction with overflow freely allowed.
  (word-add x (word-neg y)))
 
(: word-mul (Word Word -> Word))
(define (word-mul x y)
  ;; Signed multiplication.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-xy (cast (bitwise-and (* abs-x abs-y) #xFFFFFFFF)
                           Word)))
        (if x<0
            (if y<0 abs-xy (word-neg abs-xy))
            (if y<0 (word-neg abs-xy) abs-xy))))))
 
(: word-div (Word Word -> Word))
(define (word-div x y)
  ;; The quotient after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (quotient abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))
 
(: word-mod (Word Word -> Word))
(define (word-mod x y)
  ;; The remainder after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (remainder abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))
 
(: b2i (Boolean -> (U Zero One)))
(define (b2i b)
  (if b 1 0))
 
(: word-lt (Word Word -> Word))
(define (word-lt x y)
  ;; Signed comparison: is x less than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (< x y) #t)
             (if y<0 #f (< x y))))))
 
(: word-le (Word Word -> Word))
(define (word-le x y)
  ;; Signed comparison: is x less than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (<= x y) #t)
             (if y<0 #f (<= x y))))))
 
(: word-gt (Word Word -> Word))
(define (word-gt x y)
  ;; Signed comparison: is x greater than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (> x y) #f)
             (if y<0 #t (> x y))))))
 
(: word-ge (Word Word -> Word))
(define (word-ge x y)
  ;; Signed comparison: is x greater than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (>= x y) #f)
             (if y<0 #t (>= x y))))))
 
(: word-eq (Word Word -> Word))
(define (word-eq x y)
  ;; Is x equal to y?
  (b2i (= x y)))
 
(: word-ne (Word Word -> Word))
(define (word-ne x y)
  ;; Is x not equal to y?
  (b2i (not (= x y))))
 
(: word-cmp (Word -> Word))
(define (word-cmp x)
  ;; The logical complement.
  (b2i (zero? x)))
 
(: word-and (Word Word -> Word))
(define (word-and x y)
  ;; The logical conjunction.
  (b2i (and (not (zero? x)) (not (zero? y)))))
 
(: word-or (Word Word -> Word))
(define (word-or x y)
  ;; The logical disjunction.
  (b2i (or (not (zero? x)) (not (zero? y)))))
 
(: unop (Stack-Memory Register (Word -> Word) -> Void))
(define (unop stack sp operation)
  ;; Perform a unary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      ;; Note how, in contrast to Common Lisp, "operation" is not in a
      ;; namespace separate from that of "ordinary" values, such as
      ;; numbers and strings. (Which way is "better" is a matter of
      ;; taste, and probably depends mostly on what "functional"
      ;; language one learnt first. Mine was Caml Light, so I prefer
      ;; the Scheme way. :) )
      (vector-set! stack (- i 1) (operation x)))))
 
(: binop (Stack-Memory Register (Word Word -> Word) -> Void))
(define (binop stack sp operation)
  ;; Perform a binary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 2 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 2)))
          (y (vector-ref stack (- i 1))))
      (vector-set! stack (- i 2) (operation x y)))
    (set-box! sp (cast (- i 1) Word))))
 
(: jri (Executable-Memory Register -> Void))
(define (jri code ip)
  ;; Jump relative immediate.
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((offset (vector-ref code (+ j 3)))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 2)) 8)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 1)) 16)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code j) 24)
                    offset)))
      (set-box! ip (word-add j (cast offset Word))))))
 
(: jriz (Stack-Memory Register Executable-Memory Register -> Void))
(define (jriz stack sp code ip)
  ;; Jump relative immediate, if zero.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      (if (zero? x)
          (jri code ip)
          (let ((j (unbox ip)))
            (set-box! ip (cast (+ j 4) Word)))))))
 
(: get-immediate-value (Executable-Memory Register -> Word))
(define (get-immediate-value code ip)
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((x (vector-ref code (+ j 3)))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 2)) 8)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 1)) 16)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code j) 24)
               x)))
      (set-box! ip (cast (+ j 4) Word))
      (cast x Word))))
 
(: pushi (Stack-Memory Register Executable-Memory Register -> Void))
(define (pushi stack sp code ip)
  ;; Push-immediate a value from executable memory onto the stack.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (vector-set! stack i (get-immediate-value code ip))
    (set-box! sp (cast (+ i 1) Word))))
 
(: fetch (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (fetch stack sp code ip data)
  ;; Fetch data to the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (let* ((k (get-immediate-value code ip))
           (x (vector-ref data k)))
      (vector-set! stack i x)
      (set-box! sp (cast (+ i 1) Word)))))
 
(: pop-one (Stack-Memory Register -> Word))
(define (pop-one stack sp)
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let* ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      x)))
 
(: store (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (store stack sp code ip data)
  ;; Store data from the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((k (get-immediate-value code ip))
          (x (pop-one stack sp)))
      (vector-set! data k x))))
 
(: prti (Stack-Memory Register Output-Port -> Void))
(define (prti stack sp outf)
  ;; Print the top value of the stack, as a signed decimal value.
  (let* ((n (pop-one stack sp))
         (n<0 (word-signbit? n)))
    (if n<0
        (begin (display "-" outf)
               (display (word-neg n) outf))
        (display n outf))))
 
(: prtc (Stack-Memory Register Output-Port -> Void))
(define (prtc stack sp outf)
  ;; Print the top value of the stack, as a character.
  (let ((c (pop-one stack sp)))
    (display (integer->char c) outf)))
 
(: prts (Stack-Memory
         Register (Immutable-Vectorof String) Output-Port -> Void))
(define (prts stack sp strings outf)
  ;; Print the string specified by the top of the stack.
  (let* ((k (pop-one stack sp))
         (s (vector-ref strings k)))
    (display s outf)))
 
;;
;; I have written macros in the standard R6RS fashion, with a lambda
;; and syntax-case, so the examples may be widely illustrative. Racket
;; supports this style, despite (purposely) not adhering to any Scheme
;; standard.
;;
;; Some Schemes that do not provide syntax-case (CHICKEN, for
;; instance) provide alternatives that may be quite different.
;;
;; R5RS and R7RS require only syntax-rules, which cannot do what we
;; are doing here. (What we are doing is similar to using ## in a
;; modern C macro, except that the pieces are not merely raw text, and
;; they must be properly typed at every stage.)
;;
(define-syntax define-machine-binop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (binop (machine-stack mach)
                      (machine-sp mach)
                      #,word-op))))))))
 
(define-syntax define-machine-unop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (unop (machine-stack mach)
                     (machine-sp mach)
                     #,word-op))))))))
 
(define-machine-binop "add")
(define-machine-binop "sub")
(define-machine-binop "mul")
(define-machine-binop "div")
(define-machine-binop "mod")
(define-machine-binop "lt")
(define-machine-binop "gt")
(define-machine-binop "le")
(define-machine-binop "ge")
(define-machine-binop "eq")
(define-machine-binop "ne")
(define-machine-binop "and")
(define-machine-binop "or")
 
(define-machine-unop "neg")
 
(: machine-not (Machine -> Void))
(define (machine-not mach)
  (unop (machine-stack mach)
        (machine-sp mach)
        word-cmp))
 
(: machine-prtc (Machine -> Void))
(define (machine-prtc mach)
  (prtc (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))
 
(: machine-prti (Machine -> Void))
(define (machine-prti mach)
  (prti (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))
 
(: machine-prts (Machine -> Void))
(define (machine-prts mach)
  (prts (machine-stack mach)
        (machine-sp mach)
        (machine-strings mach)
        (machine-output mach)))
 
(: machine-fetch (Machine -> Void))
(define (machine-fetch mach)
  (fetch (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))
 
(: machine-store (Machine -> Void))
(define (machine-store mach)
  (store (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))
 
(: machine-push (Machine -> Void))
(define (machine-push mach)
  (pushi (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)))
 
(: machine-jmp (Machine -> Void))
(define (machine-jmp mach)
  (jri (machine-code mach)
       (machine-ip mach)))
 
(: machine-jz (Machine -> Void))
(define (machine-jz mach)
  (jriz (machine-stack mach)
        (machine-sp mach)
        (machine-code mach)
        (machine-ip mach)))
 
(: get-opcode (Machine -> Byte))
(define (get-opcode mach)
  (let ((code (machine-code mach))
        (ip (machine-ip mach)))
    (let ((j (unbox ip)))
      (unless (< j executable-memory-size)
        (raise-user-error "address past end of executable memory"))
      (let ((opcode (vector-ref code j)))
        (set-box! ip (cast (+ j 1) Word))
        opcode))))
 
(: run-instruction (Machine Byte -> Void))
(define (run-instruction mach opcode)
  (let ((op-mod-4 (bitwise-and opcode #x3))
        (op-div-4 (arithmetic-shift opcode -2)))
    (match op-div-4
      (0 (match op-mod-4
           (1 (machine-add mach))
           (2 (machine-sub mach))
           (3 (machine-mul mach))))
      (1 (match op-mod-4
           (0 (machine-div mach))
           (1 (machine-mod mach))
           (2 (machine-lt mach))
           (3 (machine-gt mach))))
      (2 (match op-mod-4
           (0 (machine-le mach))
           (1 (machine-ge mach))
           (2 (machine-eq mach))
           (3 (machine-ne mach))))
      (3 (match op-mod-4
           (0 (machine-and mach))
           (1 (machine-or mach))
           (2 (machine-neg mach))
           (3 (machine-not mach))))
      (4 (match op-mod-4
           (0 (machine-prtc mach))
           (1 (machine-prti mach))
           (2 (machine-prts mach))
           (3 (machine-fetch mach))))
      (5 (match op-mod-4
           (0 (machine-store mach))
           (1 (machine-push mach))
           (2 (machine-jmp mach))
           (3 (machine-jz mach)))))))
 
(: run-vm (Machine -> Void))
(define (run-vm mach)
  (let ((opcode-for-halt (cast (opcode-from-name "halt") Byte))
        (opcode-for-add (cast (opcode-from-name "add") Byte))
        (opcode-for-jz (cast (opcode-from-name "jz") Byte)))
    (let loop ((opcode (get-opcode mach)))
      (unless (= opcode opcode-for-halt)
        (begin
          (when (or (< opcode opcode-for-add)
                    (< opcode-for-jz opcode))
            (raise-user-error "unsupported opcode"))
          (run-instruction mach opcode)
          (loop (get-opcode mach)))))))
 
(define (usage-error)
  (display "Usage: vm [INPUTFILE [OUTPUTFILE]]" (current-error-port))
  (newline (current-error-port))
  (display "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
           (current-error-port))
  (display " standard I/O is used." (current-error-port))
  (newline (current-error-port))
  (exit 1))
 
(: get-filenames (-> (Values String String)))
(define (get-filenames)
  (match (current-command-line-arguments)
    ((vector) (values "-" "-"))
    ((vector inpf-filename)
     (values (cast inpf-filename String) "-"))
    ((vector inpf-filename outf-filename)
     (values (cast inpf-filename String)
             (cast outf-filename String)))
    (_ (usage-error)
       (values "" ""))))
 
(let-values (((inpf-filename outf-filename) (get-filenames)))
  (let* ((inpf (open-inpf inpf-filename))
         (outf (open-outf outf-filename)))
    (let-values (((datasize strings-count)
                  (read-datasize-and-strings-count inpf)))
      (let* ((strings
              (vector->immutable-vector
               (list->vector
                (read-string-literals inpf strings-count))))
             (instructions (read-instructions inpf))
 
             (mach (make-machine strings outf)))
 
        (unless (<= datasize data-memory-size)
          (raise-user-error
           "the VM's data memory size is exceeded"))
 
        (load-executable-memory (machine-code mach) instructions)
        (run-vm mach)
 
        (unless (string=? inpf-filename "-")
          (close-input-port inpf))
        (unless (string=? outf-filename "-")
          (close-output-port outf))
 
        (exit 0)))))