726 lines
22 KiB
Common Lisp
726 lines
22 KiB
Common Lisp
#!/bin/sh
|
|
#|-*- mode:lisp -*-|#
|
|
#|
|
|
exec ros -Q -- $0 "$@"
|
|
|#
|
|
(progn ;;init forms
|
|
(ros:ensure-asdf)
|
|
#+quicklisp(ql:quickload '() :silent t)
|
|
)
|
|
|
|
(defpackage :ros.script.vm.3858678051
|
|
(:use :cl))
|
|
(in-package :ros.script.vm.3858678051)
|
|
|
|
;;;
|
|
;;; The Rosetta Code Virtual Machine, in Common Lisp.
|
|
;;;
|
|
;;; Notes:
|
|
;;;
|
|
;;; * I have tried not to use foreign types or similar means of
|
|
;;; optimization.
|
|
;;;
|
|
;;; * Integers are stored in the VM's executable memory in
|
|
;;; big-endian order. Not because I prefer it, but because I do
|
|
;;; not want to get myself into a little-endian rut.
|
|
;;;
|
|
|
|
(require "cl-ppcre")
|
|
(require "trivia")
|
|
|
|
;;; 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.
|
|
(defconstant executable-memory-size 65536
|
|
"The size of memory for executable code, in 8-bit words.")
|
|
|
|
;;; Similarly, I am going to have fixed size data and stack memory.
|
|
(defconstant data-memory-size 2048
|
|
"The size of memory for stored data, in 32-bit words.")
|
|
(defconstant stack-memory-size 2048
|
|
"The size of memory for the stack, in 32-bit words.")
|
|
|
|
;;; 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.
|
|
(deftype word ()
|
|
'(unsigned-byte 32))
|
|
(deftype register ()
|
|
'(simple-array word (1)))
|
|
(deftype executable-memory ()
|
|
`(simple-array (unsigned-byte 8) ,(list executable-memory-size)))
|
|
(deftype data-memory ()
|
|
`(simple-array word ,(list data-memory-size)))
|
|
(deftype stack-memory ()
|
|
`(simple-array word ,(list stack-memory-size)))
|
|
|
|
(defconstant re-blank-line
|
|
(ppcre:create-scanner "^\\s*$"))
|
|
|
|
(defconstant re-parse-instr-1
|
|
(ppcre:create-scanner "^\\s*(\\d+)\\s*(.*\\S)"))
|
|
|
|
(defconstant re-parse-instr-2
|
|
(ppcre:create-scanner "(?i)^(\\S+)\\s*(.*)"))
|
|
|
|
(defconstant re-parse-instr-3
|
|
(ppcre:create-scanner "^[[(]?([0-9-]+)"))
|
|
|
|
(defconstant 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"))
|
|
|
|
(defun blank-line-p (s)
|
|
(not (not (ppcre:scan re-blank-line s))))
|
|
|
|
(defun opcode-from-name (s)
|
|
(position-if (lambda (name)
|
|
(string= s name))
|
|
opcode-names))
|
|
|
|
(defun create-executable-memory ()
|
|
(coerce (make-list executable-memory-size
|
|
:initial-element (opcode-from-name "halt"))
|
|
'executable-memory))
|
|
|
|
(defun create-data-memory ()
|
|
(coerce (make-list data-memory-size :initial-element 0)
|
|
'data-memory))
|
|
|
|
(defun create-stack-memory ()
|
|
(coerce (make-list stack-memory-size :initial-element 0)
|
|
'stack-memory))
|
|
|
|
(defun create-register ()
|
|
(coerce (make-list 1 :initial-element 0) 'register))
|
|
|
|
(defstruct machine
|
|
(sp (create-register) :type register) ; Stack pointer.
|
|
(ip (create-register) :type register) ; Instruction pointer (same
|
|
; thing as program counter).
|
|
(code (create-executable-memory) :type executable-memory)
|
|
(data (create-data-memory) :type data-memory)
|
|
(stack (create-stack-memory) :type stack-memory)
|
|
(strings nil)
|
|
output *standard-output*)
|
|
|
|
(defun insert-instruction (memory instr)
|
|
(declare (type executable-memory memory))
|
|
(trivia:match instr
|
|
((list address opcode arg)
|
|
(let ((instr-size (if arg 5 1)))
|
|
(unless (<= (+ address instr-size) executable-memory-size)
|
|
(warn "the VM's executable memory size is exceeded")
|
|
(uiop:quit 1))
|
|
(setf (elt memory address) opcode)
|
|
(when arg
|
|
;; Big-endian order.
|
|
(setf (elt memory (+ address 1)) (ldb (byte 8 24) arg))
|
|
(setf (elt memory (+ address 2)) (ldb (byte 8 16) arg))
|
|
(setf (elt memory (+ address 3)) (ldb (byte 8 8) arg))
|
|
(setf (elt memory (+ address 4)) (ldb (byte 8 0) arg)))))))
|
|
|
|
(defun load-executable-memory (memory instr-lst)
|
|
(declare (type executable-memory memory))
|
|
(loop for instr in instr-lst
|
|
do (insert-instruction memory instr)))
|
|
|
|
(defun parse-instruction (s)
|
|
(if (blank-line-p s)
|
|
nil
|
|
(let* ((strings (nth-value 1 (ppcre:scan-to-strings
|
|
re-parse-instr-1 s)))
|
|
(address (parse-integer (elt strings 0)))
|
|
(split (nth-value 1 (ppcre:scan-to-strings
|
|
re-parse-instr-2 (elt strings 1))))
|
|
(opcode-name (string-downcase (elt split 0)))
|
|
(opcode (opcode-from-name opcode-name))
|
|
(arguments (elt split 1))
|
|
(has-arg (trivia:match opcode-name
|
|
((or "fetch" "store" "push" "jmp" "jz") t)
|
|
(_ nil))))
|
|
(if has-arg
|
|
(let* ((argstr-lst
|
|
(nth-value 1 (ppcre:scan-to-strings
|
|
re-parse-instr-3 arguments)))
|
|
(argstr (elt argstr-lst 0)))
|
|
`(,address ,opcode ,(parse-integer argstr)))
|
|
`(,address ,opcode ())))))
|
|
|
|
(defun read-instructions (inpf)
|
|
(loop for line = (read-line inpf nil 'eoi)
|
|
until (eq line 'eoi)
|
|
for instr = (parse-instruction line)
|
|
when instr collect instr))
|
|
|
|
(defun read-datasize-and-strings-count (inpf)
|
|
(let ((line (read-line inpf)))
|
|
(multiple-value-bind (_whole-match strings)
|
|
;; This is a permissive implementation.
|
|
(ppcre:scan-to-strings
|
|
"(?i)^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+)"
|
|
line)
|
|
(declare (ignore _whole-match))
|
|
`(,(parse-integer (elt strings 0))
|
|
,(parse-integer (elt strings 1))))))
|
|
|
|
(defun 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 (ppcre:regex-replace "^\\s*" s ""))
|
|
(quote-mark (elt s 0))
|
|
(i 1)
|
|
(lst
|
|
(loop until (char= (elt s i) quote-mark)
|
|
collect (let ((c (elt s i)))
|
|
(if (char= c #\\)
|
|
(let ((c0 (trivia:match (elt s (1+ i))
|
|
(#\n #\newline)
|
|
(c1 c1))))
|
|
(setq i (+ i 2))
|
|
c0)
|
|
(progn
|
|
(setq i (1+ i))
|
|
c))))))
|
|
(coerce lst 'string)))
|
|
|
|
(defun read-string-literals (inpf strings-count)
|
|
(loop for i from 1 to strings-count
|
|
collect (parse-string-literal (read-line inpf))))
|
|
|
|
(defun open-inpf (inpf-filename)
|
|
(if (string= inpf-filename "-")
|
|
*standard-input*
|
|
(open inpf-filename :direction :input)))
|
|
|
|
(defun open-outf (outf-filename)
|
|
(if (string= outf-filename "-")
|
|
*standard-output*
|
|
(open outf-filename :direction :output
|
|
:if-exists :overwrite
|
|
:if-does-not-exist :create)))
|
|
|
|
(defun word-signbit-p (x)
|
|
"True if and only if the sign bit is set."
|
|
(declare (type word x))
|
|
(/= 0 (logand x #x80000000)))
|
|
|
|
(defun word-add (x y)
|
|
"Addition with overflow freely allowed."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(coerce (logand (+ x y) #xFFFFFFFF) 'word))
|
|
|
|
(defun word-neg (x)
|
|
"The two's complement."
|
|
(declare (type word x))
|
|
(word-add (logxor x #xFFFFFFFF) 1))
|
|
|
|
(defun word-sub (x y)
|
|
"Subtraction with overflow freely allowed."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(word-add x (word-neg y)))
|
|
|
|
(defun word-mul (x y)
|
|
"Signed multiplication."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-xy (the word
|
|
(logand (* abs-x abs-y) #xFFFFFFFF))))
|
|
(if x<0
|
|
(if y<0 abs-xy (word-neg abs-xy))
|
|
(if y<0 (word-neg abs-xy) abs-xy))))))
|
|
|
|
(defun word-div (x y)
|
|
"The quotient after signed integer division with truncation towards
|
|
zero."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-x/y (the word
|
|
(logand (floor abs-x abs-y) #xFFFFFFFF))))
|
|
(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))))))
|
|
|
|
(defun word-mod (x y)
|
|
"The remainder after signed integer division with truncation towards
|
|
zero."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-x%y (the word
|
|
(logand (nth-value 1 (floor abs-x abs-y))
|
|
#xFFFFFFFF))))
|
|
(if x<0 (word-neg abs-x%y) abs-x%y)))))
|
|
|
|
(defun b2i (b)
|
|
(declare (type boolean b))
|
|
(if b 1 0))
|
|
|
|
(defun word-lt (x y)
|
|
"Signed comparison: is x less than y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(b2i (if x<0
|
|
(if y<0 (< x y) t)
|
|
(if y<0 nil (< x y))))))
|
|
|
|
(defun word-le (x y)
|
|
"Signed comparison: is x less than or equal to y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(b2i (if x<0
|
|
(if y<0 (<= x y) t)
|
|
(if y<0 nil (<= x y))))))
|
|
|
|
(defun word-gt (x y)
|
|
"Signed comparison: is x greater than y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(b2i (if x<0
|
|
(if y<0 (> x y) nil)
|
|
(if y<0 t (> x y))))))
|
|
|
|
(defun word-ge (x y)
|
|
"Signed comparison: is x greater than or equal to y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(let ((x<0 (word-signbit-p x))
|
|
(y<0 (word-signbit-p y)))
|
|
(b2i (if x<0
|
|
(if y<0 (>= x y) nil)
|
|
(if y<0 t (>= x y))))))
|
|
|
|
(defun word-eq (x y)
|
|
"Is x equal to y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(b2i (= x y)))
|
|
|
|
(defun word-ne (x y)
|
|
"Is x not equal to y?"
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(b2i (/= x y)))
|
|
|
|
(defun word-cmp (x)
|
|
"The logical complement."
|
|
(declare (type word x))
|
|
(b2i (= x 0)))
|
|
|
|
(defun word-and (x y)
|
|
"The logical conjunction."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(b2i (and (/= x 0) (/= y 0))))
|
|
|
|
(defun word-or (x y)
|
|
"The logical disjunction."
|
|
(declare (type word x))
|
|
(declare (type word y))
|
|
(b2i (or (/= x 0) (/= y 0))))
|
|
|
|
(defun unop (stack sp operation)
|
|
"Perform a unary operation on the stack."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type (function (word) word) operation))
|
|
(let ((i (elt sp 0)))
|
|
(unless (<= 1 i)
|
|
(warn "stack underflow")
|
|
(uiop:quit 1))
|
|
(let ((x (elt stack (1- i))))
|
|
(setf (elt stack (1- i)) (funcall operation x)))))
|
|
|
|
(defun binop (stack sp operation)
|
|
"Perform a binary operation on the stack."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type (function (word word) word) operation))
|
|
(let ((i (elt sp 0)))
|
|
(unless (<= 2 i)
|
|
(warn "stack underflow")
|
|
(uiop:quit 1))
|
|
(let ((x (elt stack (- i 2)))
|
|
(y (elt stack (1- i))))
|
|
(setf (elt stack (- i 2)) (funcall operation x y)))
|
|
(setf (elt sp 0) (1- i))))
|
|
|
|
(defun jri (code ip)
|
|
"Jump relative immediate."
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
;; Big-endian order.
|
|
(let ((j (elt ip 0)))
|
|
(unless (<= (+ j 4) executable-memory-size)
|
|
(warn "address past end of executable memory")
|
|
(uiop:quit 1))
|
|
(let* ((offset (elt code (+ j 3)))
|
|
(offset (dpb (elt code (+ j 2)) (byte 8 8) offset))
|
|
(offset (dpb (elt code (+ j 1)) (byte 8 16) offset))
|
|
(offset (dpb (elt code j) (byte 8 24) offset)))
|
|
(setf (elt ip 0) (word-add j offset)))))
|
|
|
|
(defun jriz (stack sp code ip)
|
|
"Jump relative immediate, if zero."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
(let ((i (elt sp 0)))
|
|
(unless (<= 1 i)
|
|
(warn "stack underflow")
|
|
(uiop:quit 1))
|
|
(let ((x (elt stack (1- i))))
|
|
(setf (elt sp 0) (1- i))
|
|
(if (= x 0)
|
|
(jri code ip)
|
|
(setf (elt ip 0) (+ (elt ip 0) 4))))))
|
|
|
|
(defun get-immediate-value (code ip)
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
;; Big-endian order.
|
|
(let ((j (elt ip 0)))
|
|
(unless (<= (+ j 4) executable-memory-size)
|
|
(warn "address past end of executable memory")
|
|
(uiop:quit 1))
|
|
(let* ((x (elt code (+ j 3)))
|
|
(x (dpb (elt code (+ j 2)) (byte 8 8) x))
|
|
(x (dpb (elt code (+ j 1)) (byte 8 16) x))
|
|
(x (dpb (elt code j) (byte 8 24) x)))
|
|
(setf (elt ip 0) (+ j 4))
|
|
x)))
|
|
|
|
(defun pushi (stack sp code ip)
|
|
"Push-immediate a value from executable memory onto the stack."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
(let ((i (elt sp 0)))
|
|
(unless (< i stack-memory-size)
|
|
(warn "stack overflow")
|
|
(uiop:quit 1))
|
|
(setf (elt stack i) (get-immediate-value code ip))
|
|
(setf (elt sp 0) (1+ i))))
|
|
|
|
(defun fetch (stack sp code ip data)
|
|
"Fetch data to the stack, using the storage location given in
|
|
executable memory."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
(declare (type data-memory data))
|
|
(let ((i (elt sp 0)))
|
|
(unless (< i stack-memory-size)
|
|
(warn "stack overflow")
|
|
(uiop:quit 1))
|
|
(let* ((k (get-immediate-value code ip))
|
|
(x (elt data k)))
|
|
(setf (elt stack i) x)
|
|
(setf (elt sp 0) (1+ i)))))
|
|
|
|
(defun pop-one (stack sp)
|
|
(let ((i (elt sp 0)))
|
|
(unless (<= 1 i)
|
|
(warn "stack underflow")
|
|
(uiop:quit 1))
|
|
(let* ((x (elt stack (1- i))))
|
|
(setf (elt sp 0) (1- i))
|
|
x)))
|
|
|
|
(defun store (stack sp code ip data)
|
|
"Store data from the stack, using the storage location given in
|
|
executable memory."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(declare (type executable-memory code))
|
|
(declare (type register ip))
|
|
(declare (type data-memory data))
|
|
(let ((i (elt sp 0)))
|
|
(unless (<= 1 i)
|
|
(warn "stack underflow")
|
|
(uiop:quit 1))
|
|
(let ((k (get-immediate-value code ip))
|
|
(x (pop-one stack sp)))
|
|
(setf (elt data k) x))))
|
|
|
|
(defun prti (stack sp outf)
|
|
"Print the top value of the stack, as a signed decimal value."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(let* ((n (pop-one stack sp))
|
|
(n<0 (word-signbit-p n)))
|
|
(if n<0
|
|
(format outf "-~D" (word-neg n))
|
|
(format outf "~D" n))))
|
|
|
|
(defun prtc (stack sp outf)
|
|
"Print the top value of the stack, as a character."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(let* ((c (pop-one stack sp)))
|
|
(format outf "~C" (code-char c))))
|
|
|
|
(defun prts (stack sp strings outf)
|
|
"Print the string specified by the top of the stack."
|
|
(declare (type stack-memory stack))
|
|
(declare (type register sp))
|
|
(let* ((k (pop-one stack sp))
|
|
(s (elt strings k)))
|
|
(format outf "~A" s)))
|
|
|
|
(defmacro defun-machine-binop (op)
|
|
(let ((machine-op (read-from-string
|
|
(concatenate 'string "machine-" (string op))))
|
|
(word-op (read-from-string
|
|
(concatenate 'string "word-" (string op)))))
|
|
`(defun ,machine-op (mach)
|
|
(declare (type machine mach))
|
|
(binop (machine-stack mach)
|
|
(machine-sp mach)
|
|
#',word-op))))
|
|
|
|
(defmacro defun-machine-unop (op)
|
|
(let ((machine-op (read-from-string
|
|
(concatenate 'string "machine-" (string op))))
|
|
(word-op (read-from-string
|
|
(concatenate 'string "word-" (string op)))))
|
|
`(defun ,machine-op (mach)
|
|
(declare (type machine mach))
|
|
(unop (machine-stack mach)
|
|
(machine-sp mach)
|
|
#',word-op))))
|
|
|
|
(defun-machine-binop "add")
|
|
(defun-machine-binop "sub")
|
|
(defun-machine-binop "mul")
|
|
(defun-machine-binop "div")
|
|
(defun-machine-binop "mod")
|
|
(defun-machine-binop "lt")
|
|
(defun-machine-binop "gt")
|
|
(defun-machine-binop "le")
|
|
(defun-machine-binop "ge")
|
|
(defun-machine-binop "eq")
|
|
(defun-machine-binop "ne")
|
|
(defun-machine-binop "and")
|
|
(defun-machine-binop "or")
|
|
|
|
(defun-machine-unop "neg")
|
|
(defun machine-not (mach)
|
|
(declare (type machine mach))
|
|
(unop (machine-stack mach)
|
|
(machine-sp mach)
|
|
#'word-cmp))
|
|
|
|
(defun machine-prtc (mach)
|
|
(declare (type machine mach))
|
|
(prtc (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-output mach)))
|
|
|
|
(defun machine-prti (mach)
|
|
(declare (type machine mach))
|
|
(prti (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-output mach)))
|
|
|
|
(defun machine-prts (mach)
|
|
(declare (type machine mach))
|
|
(prts (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-strings mach)
|
|
(machine-output mach)))
|
|
|
|
(defun machine-fetch (mach)
|
|
(declare (type machine mach))
|
|
(fetch (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)
|
|
(machine-data mach)))
|
|
|
|
(defun machine-store (mach)
|
|
(declare (type machine mach))
|
|
(store (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)
|
|
(machine-data mach)))
|
|
|
|
(defun machine-push (mach)
|
|
(declare (type machine mach))
|
|
(pushi (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(defun machine-jmp (mach)
|
|
(declare (type machine mach))
|
|
(jri (machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(defun machine-jz (mach)
|
|
(declare (type machine mach))
|
|
(jriz (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(defun get-opcode (mach)
|
|
(declare (type machine mach))
|
|
(let ((code (machine-code mach))
|
|
(ip (machine-ip mach)))
|
|
(let ((j (elt ip 0)))
|
|
(unless (< j executable-memory-size)
|
|
(warn "address past end of executable memory")
|
|
(uiop:quit 1))
|
|
(let ((opcode (elt code j)))
|
|
(setf (elt ip 0) (1+ j))
|
|
opcode))))
|
|
|
|
(defun run-instruction (mach opcode)
|
|
(declare (type machine mach))
|
|
(declare (type fixnum opcode))
|
|
(let ((op-mod-4 (logand opcode #x3))
|
|
(op-div-4 (ash opcode -2)))
|
|
(trivia:match op-div-4
|
|
(0 (trivia:match op-mod-4
|
|
(1 (machine-add mach))
|
|
(2 (machine-sub mach))
|
|
(3 (machine-mul mach))))
|
|
(1 (trivia:match op-mod-4
|
|
(0 (machine-div mach))
|
|
(1 (machine-mod mach))
|
|
(2 (machine-lt mach))
|
|
(3 (machine-gt mach))))
|
|
(2 (trivia:match op-mod-4
|
|
(0 (machine-le mach))
|
|
(1 (machine-ge mach))
|
|
(2 (machine-eq mach))
|
|
(3 (machine-ne mach))))
|
|
(3 (trivia:match op-mod-4
|
|
(0 (machine-and mach))
|
|
(1 (machine-or mach))
|
|
(2 (machine-neg mach))
|
|
(3 (machine-not mach))))
|
|
(4 (trivia:match op-mod-4
|
|
(0 (machine-prtc mach))
|
|
(1 (machine-prti mach))
|
|
(2 (machine-prts mach))
|
|
(3 (machine-fetch mach))))
|
|
(5 (trivia:match op-mod-4
|
|
(0 (machine-store mach))
|
|
(1 (machine-push mach))
|
|
(2 (machine-jmp mach))
|
|
(3 (machine-jz mach)))))))
|
|
|
|
(defun run-vm (mach)
|
|
(declare (type machine mach))
|
|
(let ((opcode-for-halt (the fixnum (opcode-from-name "halt")))
|
|
(opcode-for-add (the fixnum (opcode-from-name "add")))
|
|
(opcode-for-jz (the fixnum (opcode-from-name "jz"))))
|
|
(loop for opcode = (the fixnum (get-opcode mach))
|
|
until (= opcode opcode-for-halt)
|
|
do (progn (when (or (< opcode opcode-for-add)
|
|
(< opcode-for-jz opcode))
|
|
(warn "unsupported opcode")
|
|
(uiop:quit 1))
|
|
(run-instruction mach opcode)))))
|
|
|
|
(defun usage-error ()
|
|
(princ "Usage: vm [INPUTFILE [OUTPUTFILE]]" *standard-output*)
|
|
(terpri *standard-output*)
|
|
(princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
|
|
*standard-output*)
|
|
(princ " standard I/O is used." *standard-output*)
|
|
(terpri *standard-output*)
|
|
(uiop:quit 1))
|
|
|
|
(defun get-filenames (argv)
|
|
(trivia:match argv
|
|
((list) '("-" "-"))
|
|
((list inpf-filename) `(,inpf-filename "-"))
|
|
((list inpf-filename outf-filename) `(,inpf-filename
|
|
,outf-filename))
|
|
(_ (usage-error))))
|
|
|
|
(defun main (&rest argv)
|
|
(let* ((filenames (get-filenames argv))
|
|
(inpf-filename (car filenames))
|
|
(inpf (open-inpf inpf-filename))
|
|
(outf-filename (cadr filenames))
|
|
(outf (open-outf outf-filename))
|
|
|
|
(sizes (read-datasize-and-strings-count inpf))
|
|
(datasize (car sizes))
|
|
(strings-count (cadr sizes))
|
|
(strings (read-string-literals inpf strings-count))
|
|
(instructions (read-instructions inpf))
|
|
;; We shall remain noncommittal about how strings are stored
|
|
;; on the hypothetical machine.
|
|
(strings (coerce strings 'simple-vector))
|
|
|
|
(mach (make-machine :strings strings
|
|
:output outf)))
|
|
|
|
(unless (<= datasize data-memory-size)
|
|
(warn "the VM's data memory size is exceeded")
|
|
(uiop:quit 1))
|
|
|
|
(load-executable-memory (machine-code mach) instructions)
|
|
(run-vm mach)
|
|
|
|
(unless (string= inpf-filename "-")
|
|
(close inpf))
|
|
(unless (string= outf-filename "-")
|
|
(close outf))
|
|
|
|
(uiop:quit 0)))
|
|
|
|
;;; vim: set ft=lisp lisp:
|