#lang racket

(define ip 0)                                    ; instruction pointer
(define sp 0)                                    ; data stack pointer
(define rp 0)                                    ; address stack pointer
(define ds (make-vector 33 0))                   ; data stack
(define as (make-vector 257 0))                  ; address stack
(define m (make-vector 65536 0))                 ; memory

(define blk (make-vector 1024 0))                ; block buffer
(define blocks "ilo.blocks")
(define rom "ilo.rom")

(define i (make-vector 4 0))

(define (fixint n)
  (let* ((unsigned (bitwise-and n #xffffffff))
         (sign-bit #x80000000))
    (if (not (zero? (bitwise-and unsigned sign-bit)))
        (- unsigned #x100000000)
        unsigned)))

(define (push! v)
  (set! sp (+ sp 1))
  (vector-set! ds sp (fixint v)))

(define (pop!)
  (let ((value (vector-ref ds sp)))
    (set! sp (- sp 1))
    value))

(define (read-byte-safe port)
  (let ((b (read-byte port)))
    (if (eof-object? b) 0 b)))

(define (read-integers-into-vector vec filename offset)
  (let ((port (open-input-file filename #:mode 'binary)))
    (file-position port offset)
    (let loop ((idx 0))
      (when (< idx (vector-length vec))
        (let* ((b0 (read-byte-safe port))
               (b1 (read-byte-safe port))
               (b2 (read-byte-safe port))
               (b3 (read-byte-safe port))
               (value (bitwise-ior b0
                                   (arithmetic-shift b1 8)
                                   (arithmetic-shift b2 16)
                                   (arithmetic-shift b3 24))))
          (vector-set! vec idx (fixint value))
          (loop (+ idx 1)))))
    (close-input-port port)))

(define (load-image)
  (read-integers-into-vector m rom 0)
  (set! ip 0)
  (set! sp 0)
  (set! rp 0))

(define (save-image) (void))

(define (vector-copy-into! destination dest-start source source-start len)
  (let loop ((n 0))
    (when (< n len)
      (vector-set! destination (+ dest-start n)
                   (vector-ref source (+ source-start n)))
      (loop (+ n 1)))))

(define (vector-slice vec start len)
  (let ((result (make-vector len 0)))
    (vector-copy-into! result 0 vec start len)
    result))

(define (read-block)
  (let ((b (pop!))
        (a (pop!)))
    (read-integers-into-vector blk blocks (* 4096 a))
    (vector-copy-into! m b blk 0 1024)))

(define (write-int32 port value)
  (let ((n (bitwise-and value #xffffffff)))
    (write-byte (bitwise-and n #xff) port)
    (write-byte (bitwise-and (arithmetic-shift n -8) #xff) port)
    (write-byte (bitwise-and (arithmetic-shift n -16) #xff) port)
    (write-byte (bitwise-and (arithmetic-shift n -24) #xff) port)))

(define (write-block)
  (let ((b (pop!))
        (a (pop!)))
    (let ((segment (vector-slice m b 1024))
          (port (open-output-file blocks #:mode 'binary #:exists 'update)))
      (file-position port (* 4096 a))
      (let loop ((idx 0))
        (when (< idx 1024)
          (write-int32 port (vector-ref segment idx))
          (loop (+ idx 1))))
      (close-output-port port))))

(define (save-ip)
  (set! rp (+ rp 1))
  (vector-set! as rp ip))

(define (li)
  (set! ip (+ ip 1))
  (push! (vector-ref m ip)))

(define (du)
  (push! (vector-ref ds sp)))

(define (dr)
  (vector-set! ds sp 0)
  (set! sp (- sp 1)))

(define (sw)
  (let ((a (vector-ref ds sp))
        (sp-1 (- sp 1)))
    (vector-set! ds sp (vector-ref ds sp-1))
    (vector-set! ds sp-1 a)))

(define (pu)
  (set! rp (+ rp 1))
  (vector-set! as rp (pop!)))

(define (po)
  (push! (vector-ref as rp))
  (set! rp (- rp 1)))

(define (ju)
  (set! ip (- (pop!) 1)))

(define (ca)
  (save-ip)
  (set! ip (- (pop!) 1)))

(define (cc)
  (let ((a (pop!)))
    (when (not (zero? (pop!)))
      (save-ip)
      (set! ip (- a 1)))))

(define (cj)
  (let ((a (pop!)))
    (when (not (zero? (pop!)))
      (set! ip (- a 1)))))

(define (re)
  (set! ip (vector-ref as rp))
  (set! rp (- rp 1)))

(define (_eq)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (if (= n t) -1 0))
    (set! sp sp-1)))

(define (ne)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (if (not (= n t)) -1 0))
    (set! sp sp-1)))

(define (lt)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (if (< n t) -1 0))
    (set! sp sp-1)))

(define (gt)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (if (> n t) -1 0))
    (set! sp sp-1)))

(define (fe)
  (let ((addr (vector-ref ds sp)))
    (vector-set! ds sp (vector-ref m addr))))

(define (st)
  (let ((addr (vector-ref ds sp))
        (val (vector-ref ds (- sp 1))))
    (vector-set! m addr val)
    (set! sp (- sp 2))))

(define (ad)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (+ n t)))
    (set! sp sp-1)))

(define (su)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (- n t)))
    (set! sp sp-1)))

(define (mu)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (* n t)))
    (set! sp sp-1)))

(define (di)
  (let* ((sp-1 (- sp 1))
         (a (vector-ref ds sp))
         (b (vector-ref ds sp-1))
         (q (fixint (quotient b a)))
         (r (fixint (remainder b a))))
    (vector-set! ds sp q)
    (vector-set! ds sp-1 r)
    (when (and (>= b 0) (< r 0))
      (vector-set! ds sp (+ q 1))
      (vector-set! ds sp-1 (- r a)))))

(define (an)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (bitwise-and n t)))
    (set! sp sp-1)))

(define (_or)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (bitwise-ior n t)))
    (set! sp sp-1)))

(define (xo)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (bitwise-xor n t)))
    (set! sp sp-1)))

(define (sl)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (arithmetic-shift n t)))
    (set! sp sp-1)))

(define (sr)
  (let* ((sp-1 (- sp 1))
         (n (vector-ref ds sp-1))
         (t (vector-ref ds sp)))
    (vector-set! ds sp-1 (fixint (arithmetic-shift n (- t))))
    (set! sp sp-1)))

(define (cp)
  (let ((l (pop!))
        (d (pop!))
        (s (vector-ref ds sp)))
    (vector-set! ds sp -1)
    (let loop ((idx 0) (d d) (s s))
      (when (< idx l)
        (when (not (= (vector-ref m d) (vector-ref m s)))
          (vector-set! ds sp 0))
        (loop (+ idx 1) (+ d 1) (+ s 1))))))

(define (cy)
  (let ((l (pop!))
        (d (pop!))
        (s (pop!)))
    (let loop ((idx 0) (d d) (s s))
      (when (< idx l)
        (vector-set! m d (vector-ref m s))
        (loop (+ idx 1) (+ d 1) (+ s 1))))))

(define (ioa)
  (write-char (integer->char (pop!))))

(define (iob)
  (push! (char->integer (read-char))))

(define (ioc) (read-block))
(define (iod) (write-block))
(define (ioe) (save-image))

(define (iof)
  (load-image)
  (set! ip -1))

(define (iog)
  (set! ip 65536))

(define (ioh)
  (push! sp)
  (push! rp))

(define (io)
  (case (pop!)
    ((0) (ioa))
    ((1) (iob))
    ((2) (ioc))
    ((3) (iod))
    ((4) (ioe))
    ((5) (iof))
    ((6) (iog))
    ((7) (ioh))
    (else (void))))

(define (process opcode)
  (case opcode
    ((0) (void))
    ((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))
    (else (void))))

(define (process-bundle opcode)
  (let ((op1 (bitwise-and opcode #xff))
        (op2 (bitwise-and (arithmetic-shift opcode -8) #xff))
        (op3 (bitwise-and (arithmetic-shift opcode -16) #xff))
        (op4 (bitwise-and (arithmetic-shift opcode -24) #xff)))
    (process op1)
    (process op2)
    (process op3)
    (process op4)))

(define (_execute)
  (let loop ()
    (when (< ip 65536)
      (process-bundle (vector-ref m ip))
      (set! ip (+ ip 1))
      (loop))))

(define (main)
  (load-image)
  (_execute))

(main)
(exit 0)