ilo-vm/source/ilo.cl

328 lines
7 KiB
Common Lisp
Raw Normal View History

;; *************************************************************
;; crc's _ _
;; (_) | ___
;; | | |/ _ \ a tiny virtual computer
;; | | | (_) | 64kw RAM, 32-bit, Dual Stack, MISC
;; |_|_|\___/ ilo.cl (c) charles childers
;; *************************************************************
(declaim (optimize (speed 3) (space 0) (safety 0) (debug 0)))
(defvar ip 0) ; instruction pointer
(defvar sp 0) ; data stack pointer
(defvar rp 0) ; address stack pointer
(defvar ds (make-array 33)) ; data stack
(defvar as (make-array 257)) ; address stack
(defvar m (make-array 65536)) ; memory
(defvar blk (make-array 1024)) ; block buffer (i/o)
(defvar blocks "ilo.blocks") ; block file name
(defvar rom "ilo.rom") ; rom file name
(defvar a 0)
(defvar b 0)
(defvar f 0)
(defvar s 0)
(defvar d 0)
(defvar l 0)
(defvar i (make-array 4))
(defvar z 0)
(defun fixint (n)
(let* ((max-value (expt 2 31))
(unsigned-n (logand n #xffffffff)))
(cond ((> unsigned-n max-value)
(- unsigned-n (* max-value 2)))
((< unsigned-n (- max-value))
(+ unsigned-n (* max-value 2)))
(t unsigned-n))))
(defun _push (v)
(setf (aref ds (1+ sp)) (fixint v))
(incf sp))
(defun _pop ()
(decf sp)
(aref ds (1+ sp)))
(defun read-integers-into-array (array filename offset)
(with-open-file (stream filename
:element-type '(unsigned-byte 8)
:direction :input)
(file-position stream offset)
(loop for i below (length array)
do (setf (svref array i)
(let ((bytes (make-array 4
:element-type '(unsigned-byte 8))))
(read-sequence bytes stream)
(fixint (logior (ash (aref bytes 0) 0)
(ash (aref bytes 1) 8)
(ash (aref bytes 2) 16)
(ash (aref bytes 3) 24))))))))
(defun load-image ()
(read-integers-into-array m rom 0))
(defun save-image ())
(defun read-block ()
(setq b (_pop)
a (_pop))
(read-integers-into-array blk blocks (* 4096 a))
(replace m blk :start1 b :end1 (+ b 1024)))
(defun copy-block-from-m (org start-index)
(let ((end-index (+ start-index 1024)))
(copy-seq (subseq org start-index end-index))))
(defun little-endian (integer)
(let ((bytes (make-array 4
:element-type '(unsigned-byte 8))))
(setf (aref bytes 0) (ldb (byte 8 0) integer))
(setf (aref bytes 1) (ldb (byte 8 8) integer))
(setf (aref bytes 2) (ldb (byte 8 16) integer))
(setf (aref bytes 3) (ldb (byte 8 24) integer))
bytes))
(defun write-block ()
(setq b (_pop)
a (_pop))
(with-open-file
(out-stream blocks
:direction :output
:if-exists :append
:element-type '(unsigned-byte 8))
(file-position out-stream (* 4096 a))
(loop for integer across (copy-block-from-m m b) do
(write-sequence (little-endian integer) out-stream))))
(defun save-ip ()
(incf rp)
(setf (aref as rp) ip))
(defun symmetric ()
(when (and (>= b 0) (< (aref ds (1- sp)) 0))
(progn
(incf (aref ds sp))
(decf (aref ds (1- sp)) b))))
(defun li ()
(incf ip)
(_push (aref m ip)))
(defun du ()
(_push (aref ds sp)))
(defun dr ()
(setf (aref ds sp) 0)
(decf sp))
(defun sw ()
(setq a (aref ds sp))
(setf (aref ds sp) (aref ds (1- sp))
(aref ds (1- sp)) a))
(defun pu ()
(incf rp)
(setf (aref as rp) (_pop)))
(defun po ()
(_push (aref as rp))
(decf rp))
(defun ju ()
(setq ip (- (_pop) 1)))
(defun ca ()
(save-ip)
(setq ip (- (_pop) 1)))
(defun cc ()
(setq a (_pop))
(when (not (zerop (_pop)))
(save-ip)
(setq ip (- a 1))))
(defun cj ()
(setq a (_pop))
(when (not (zerop (_pop)))
(setq ip (- a 1))))
(defun re ()
(setq ip (aref as rp))
(decf rp))
(defun _eq ()
(setf (aref ds (1- sp)) (if (= (aref ds (1- sp)) (aref ds sp)) -1 0))
(decf sp))
(defun ne ()
(setf (aref ds (1- sp)) (if (/= (aref ds (1- sp)) (aref ds sp)) -1 0))
(decf sp))
(defun lt ()
(setf (aref ds (1- sp)) (if (< (aref ds (1- sp)) (aref ds sp)) -1 0))
(decf sp))
(defun gt ()
(setf (aref ds (1- sp)) (if (> (aref ds (1- sp)) (aref ds sp)) -1 0))
(decf sp))
(defun fe ()
(setf (aref ds sp) (aref m (aref ds sp))))
(defun st ()
(setf (aref m (aref ds sp)) (aref ds (1- sp)))
(decf sp 2))
(defun ad ()
(setf (aref ds (1- sp)) (fixint (+ (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun su ()
(setf (aref ds (1- sp)) (fixint (- (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun mu ()
(setf (aref ds (1- sp)) (fixint (* (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun di ()
(setf a (aref ds sp)
b (aref ds (1- sp))
(aref ds sp) (fixint (floor b a))
(aref ds (1- sp)) (fixint (mod b a)))
(symmetric))
(defun an ()
(setf (aref ds (1- sp)) (fixint (logand (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun _or ()
(setf (aref ds (1- sp)) (fixint (logior (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun xo ()
(setf (aref ds (1- sp)) (fixint (logxor (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun sl ()
(setf (aref ds (1- sp)) (fixint (ash (aref ds (1- sp)) (aref ds sp))))
(decf sp))
(defun sr ()
(setf (aref ds (1- sp)) (fixint (ash (aref ds (1- sp)) (- (aref ds sp)))))
(decf sp))
(defun cp ()
(setf l (_pop)
d (_pop)
s (aref ds sp)
(aref ds sp) -1)
(loop repeat l do
(when (not (= (aref m d) (aref m s)))
(setf (aref ds sp) 0))
(decf l)
(decf s)
(decf d)))
(defun cy ()
(setf l (_pop)
d (_pop)
s (_pop))
(loop repeat l do
(setf (aref m d) (aref m s))
(incf d)
(incf s)))
(defun ioa ()
(setf d (_pop))
(write-char (code-char d) *standard-output*))
(defun iob ()
(setf d (read-char *standard-input*))
(_push (char-code d)))
(defun ioc ()
(read-block))
(defun iod ()
(write-block))
(defun ioe ()
(save-image))
(defun iof ()
(load-image)
(setf ip -1))
(defun iog ()
(setf ip 65536))
(defun ioh ()
(_push sp)
(_push rp))
(defun io ()
(case (_pop)
(0 (ioa))
(1 (iob))
(2 (ioc))
(3 (iod))
(4 (ioe))
(5 (iof))
(6 (iog))
(7 (ioh))))
(defun process (o)
(case o
(0)
(1 (li))
(2 (du))
(3 (dr))
(4 (sw))
(5 (pu))
(6 (po))
(7 (ju))
(8 (ca))
(9 (cc))
(10 (cj))
(11 (re))
(12 (_eq))
(13 (ne))
(14 (lt))
(15 (gt))
(16 (fe))
(17 (st))
(18 (ad))
(19 (su))
(20 (mu))
(21 (di))
(22 (an))
(23 (_or))
(24 (xo))
(25 (sl))
(26 (sr))
(27 (cp))
(28 (cy))
(29 (io))
(otherwise nil)))
(defun process-bundle (opcode)
(process (logand opcode #xFF))
(process (logand (ash opcode -8) #xFF))
(process (logand (ash opcode -16) #xFF))
(process (logand (ash opcode -24) #xFF)))
(defun _execute ()
(loop while (< ip 65536) do
(process-bundle (aref m ip))
(incf ip)))
(defun main ()
(load-image)
(_execute))
(main)
(quit)