ilo-vm/source/ilo.cl

;; *************************************************************
;;   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)