; basic varvara emulator implementation in scheme
;
; does not currently use any macros or advanced features. the first
; stanza defines non-portable functions across a variety of scheme
; implementations.

; === implementation-dependent functions; uncomment one stanza

; chicken scheme
(import (chicken bitwise) (chicken process-context))
(define (get-u8 port)
  (let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
(define (open-rom path) (open-input-file path #:binary))

;; ; guile, invoke with guile vm.scm ROM ...
;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
;; (define (open-rom path) (open-input-file path))
;; (define (command-line-arguments) (cdr (command-line)))

;; ; chibi scheme, invoke with ???
;; (import (scheme base) (scheme bitwise) (scheme file))
;; (import (chibi io) (chibi process))
;; (define (get-u8 port) (read-u8 port))
;; (define (open-rom path) (open-input-file path))
;; (define (display s) (write-string s))

;; ; chez scheme, invoke with chezscheme --script vm.scm ROM ...
;; (define (open-rom path) (open-file-input-port path))
;; (define (command-line-arguments) (cdr (command-line)))

; === portable scheme code follows

(define (b<< n s) (arithmetic-shift n s))
(define (b>> n s) (arithmetic-shift n (- s)))

; global state for the virtual machine
;
; we use vectors to simulate memory addresses
; we use mutable cons cells for pointer+stack pairs
(define instructions (make-vector 256))
(define mem (make-vector 65536 0))
(define dev (make-vector 256 0))
(define wst (cons 0 (make-vector 256 0)))
(define rst (cons 0 (make-vector 256 0)))
(define pc 256)
(define done #f)

; instruction modes
(define _2 #f)
(define _wst wst)
(define _rst rst)

; convert numbers to 8-bit and 16-bit values
(define (u8 n) (modulo n 256))
(define (s8 n) (- (u8 (+ n 128)) 128))
(define (u16 n) (modulo n 65536))
(define (s16 n) (- (u16 (+ n 32768)) 32768))

(define (u16->lo n) (modulo n 256))
(define (u16->hi n) (quotient n 256))
(define (hilo->u16 hi lo) (+ (* 256 hi) lo))

; pop from active stack, returning value
; uses _2, _wst, and _rst to respect instruction modes
(define (_pop) (if _2 (_pop2) (_pop1)))
(define (_pop1)
  (let* ((i (u8 (- (car _wst) 1)))
         (n (vector-ref (cdr _wst) i)))
    (set-car! _wst i)
    n))
(define (_pop2)
  (let* ((lo (_pop1)) (hi (_pop1))) (hilo->u16 hi lo)))

; push value to active stack
; uses _2, _wst, and _rst to respect instruction modes
(define (_push n) (if _2 (_push2 n) (_push1 n)))
(define (_push1 n) (_xpush1 _wst n))
(define (_push2 n) (_xpush2 _wst n))

; push value to passive stack
; uses _2, _wst, and _rst to respect instruction modes
(define (_rpush n) (if _2 (_rpush2 n) (_xpush1 _rst n)))
(define (_rpush2 n) (_xpush2 _rst n))

; push value to the given stack
(define (_xpush1 st n)
  (let ((i (car st)))
    (vector-set! (cdr st) i (u8 n))
    (set-car! st (u8 (+ i 1)))))
(define (_xpush2 st n)
  (_xpush1 st (u16->hi n))
  (_xpush1 st (u16->lo n)))

; read value from memory onto active stack
; uses _2, _wst, and _rst to respect instruction modes
(define (_read addr) (if _2 (_read2 addr) (_read1 addr)))
(define (_read1 addr) (_push1 (vector-ref mem addr)))
(define (_read2 addr) (_read1 addr) (_read1 (+ addr 1)))

; write value to memory
; uses _2 to respect instruction modes
(define (_write addr n)
  (if _2 (begin
           (vector-set! mem addr (u16->hi n))
           (vector-set! mem (+ addr 1) (u16->lo n)))
      (vector-set! mem addr n)))

; load signed 16-bit value from memory, returning value
(define (_load-s16)
  (let ((hi (vector-ref mem pc))
        (lo (vector-ref mem (+ pc 1))))
    (s16 (hilo->u16 hi lo))))

; load 8 variants of an instruction
(define (op impl s k r)
  (lambda ()
    (set! _2 s)
    (set! _wst (if r _rst _wst))
    (set! _rst (if r _wst _rst))
    (if k
        (let ((i (car _wst))) (impl) (set-car! _wst i))
        (impl))))

; base instruction implementations
;
; these assume that _2, _wst, and _rst are correctly set
; according to the instruction's mode flags.
(define (brk-impl) (set! done #t))
(define (jci-impl) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi-impl)))
(define (jmi-impl) (let ((off (_load-s16))) (set! pc (+ pc off 2))))
(define (jsi-impl) (_rpush2 (+ pc 2)) (jmi-impl))
(define (lit-impl) (_read pc) (set! pc (+ pc (if _2 2 1))))
(define (inc-impl) (_push (+ (_pop) 1)))
(define (pop-impl) (_pop))
(define (nip-impl) (let* ((a (_pop))) (_pop) (_push a)))
(define (swp-impl) (let* ((b (_pop)) (a (_pop))) (_push b) (_push a)))
(define (rot-impl) (let* ((c (_pop)) (b (_pop)) (a (_pop))) (_push b) (_push c) (_push a)))
(define (dup-impl) (let* ((a (_pop))) (_push a) (_push a)))
(define (ovr-impl) (let* ((b (_pop)) (a (_pop))) (_push a) (_push b) (_push a)))
(define (equ-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (= a b) 1 0))))
(define (neq-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (not (= a b)) 0 1))))
(define (gth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (> a b) 0 1))))
(define (lth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (< a b) 0 1))))
(define (jmp-impl) (let ((n (_pop))) (set! pc (if _2 n (+ pc (s8 n))))))
(define (jcn-impl) (if (= 0 (_pop1)) (_pop) (jmp-impl)))
(define (jsr-impl) (_rpush2 pc) (jmp-impl))
(define (sth-impl) (_rpush (_pop)))
(define (ldz-impl) (_read (_pop1)))
(define (stz-impl) (let* ((zp (_pop1)) (n (_pop))) (_write zp n)))
(define (ldr-impl) (_read (+ pc (s8 (_pop1)))))
(define (str-impl) (let* ((off (_pop1)) (n (_pop))) (_write (+ pc (s8 off)) n)))
(define (lda-impl) (_read (_pop2)))
(define (sta-impl) (let* ((addr (_pop2)) (n (_pop))) (_write addr n)))
(define (add-impl) (let* ((b (_pop)) (a (_pop))) (_push (+ a b))))
(define (sub-impl) (let* ((b (_pop)) (a (_pop))) (_push (- a b))))
(define (mul-impl) (let* ((b (_pop)) (a (_pop))) (_push (* a b))))
(define (div-impl) (let* ((b (_pop)) (a (_pop))) (_push (quotient a b))))
(define (and-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-and a b))))
(define (ora-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-ior a b))))
(define (eor-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-xor a b))))

; DEI base instruction implementation
(define (dei-impl)
  (let ((port (_pop1)))
    (if _2
        (let ((hi (_dei port))
              (lo (_dei (+ port 1))))
          (_push2 (hilo->u16 hi lo)))
        (_push1 (_dei port)))))
(define (_dei port)
  (u8 (vector-ref dev port)))

; DEO base instruction implementation
(define (deo-impl)
  (let* ((dev (_pop1)) (n (_pop)))
    (if _2
        (begin
          (_deo (u16->hi n) dev)
          (_deo (u16->lo n) (+ dev 1)))
        (_deo n dev))))
(define (_deo byte port)
  (vector-set! dev port (u8 byte))
  (cond
   ((= 24 port) (write-char (integer->char byte) (current-output-port)))
   ((= 25 port) (write-char (integer->char byte) (current-error-port)))
   (* '())))

; SFT base instruction implementation
(define (sft-impl)
  (let* ((n (_pop1))
         (a (_pop))
         (left (bitwise-and (b>> n 4) 15))
         (right (bitwise-and n 15)))
    (_push (b<< (b>> a right) left))))

; add 8 variants for a given instruction base
; flags: 2 (32, 0x20), k (128, 0x80), r (64, 0x40).
(define (add-op base impl)
  (vector-set! instructions (+ base 0)   (op impl #f #f #f))  ; ---
  (vector-set! instructions (+ base 32)  (op impl #t #f #f))  ; 2--
  (vector-set! instructions (+ base 64)  (op impl #f #f #t))  ; --r
  (vector-set! instructions (+ base 96)  (op impl #t #f #t))  ; 2-r
  (vector-set! instructions (+ base 128) (op impl #f #t #f))  ; -k-
  (vector-set! instructions (+ base 160) (op impl #t #t #f))  ; 2k-
  (vector-set! instructions (+ base 192) (op impl #t #f #t))  ; 2-r
  (vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr

; hardcoded instructions for base 0x00
(vector-set! instructions 0 brk-impl)                 ; BRK
(vector-set! instructions 32 jci-impl)                ; JCI
(vector-set! instructions 64 jmi-impl)                ; JMI
(vector-set! instructions 96 jsi-impl)                ; JSI
(vector-set! instructions 128 (op lit-impl #f #f #f)) ; LIT
(vector-set! instructions 160 (op lit-impl #t #f #f)) ; LIT2
(vector-set! instructions 192 (op lit-impl #f #f #t)) ; LITr
(vector-set! instructions 224 (op lit-impl #t #f #t)) ; LIT2r

; add instructions for base 0x01 through 0x1f
(add-op 1 inc-impl)
(add-op 2 pop-impl)
(add-op 3 nip-impl)
(add-op 3 nip-impl)
(add-op 4 swp-impl)
(add-op 5 rot-impl)
(add-op 6 dup-impl)
(add-op 7 ovr-impl)
(add-op 8 equ-impl)
(add-op 9 neq-impl)
(add-op 10 gth-impl)
(add-op 11 lth-impl)
(add-op 12 jmp-impl)
(add-op 13 jcn-impl)
(add-op 14 jsr-impl)
(add-op 15 sth-impl)
(add-op 16 ldz-impl)
(add-op 17 stz-impl)
(add-op 18 ldr-impl)
(add-op 19 str-impl)
(add-op 20 lda-impl)
(add-op 21 sta-impl)
(add-op 22 dei-impl)
(add-op 23 deo-impl)
(add-op 24 add-impl)
(add-op 25 sub-impl)
(add-op 26 mul-impl)
(add-op 27 div-impl)
(add-op 28 and-impl)
(add-op 29 ora-impl)
(add-op 30 eor-impl)
(add-op 31 sft-impl)

; evaluation loop
(define (u:eval)
  (if done '()
      (let* ((byte (vector-ref mem pc))
             (fn (vector-ref instructions byte)))
        ;; (display "*** ")
        ;; (display byte)
        ;; (display "\n")
        (set! pc (+ pc 1))
        (fn)
        (u:eval))))

(define (u:run addr)
  (set! done #f)
  (set! pc addr)
  (u:eval)
  (let ((n (vector-ref dev 15)))
    (if (= n 0) '()
        (exit (bitwise-and n 127)))))

(define (u:read-args args)
  (if (null? args)
      (u:send-input #\newline 4)
      (begin
        (u:read-arg (string->list (car args)))
        (if (null? (cdr args)) '() (u:send-input #\newline 3))
        (u:read-args (cdr args)))))

(define (u:read-arg chars)
  (if (null? chars) '()
      (begin
        (u:send-input (car chars) 2)
        (u:read-arg (cdr chars)))))

; send a character of console input with type
; types are:
; - 1 stdin
; - 2 argument data
; - 3 spacer between arguments
; - 4 spacer after arguments
(define (u:send-input c type)
  (let* ((hi (vector-ref dev 16))
         (lo (vector-ref dev 17))
         (addr (hilo->u16 hi lo)))
    (if (= 0 addr) '()
        (begin
          (vector-set! dev 18 (u8 (char->integer c)))
          (vector-set! dev 23 (u8 type))
          (u:run addr)))))

(define (u:read-stdin port)
  (let ((c (read-char port)))
    (if (eof-object? c) '()
        (begin
          (u:send-input c 1)
          (u:read-stdin port)))))

; load a ROM from a file, byte-by-byte
(define (u:load-rom rom addr)
  (let ((byte (get-u8 rom)))
    (if (eof-object? byte)
        '()
        (begin (vector-set! mem addr (u8 byte))
               (u:load-rom rom (+ addr 1))))))

(let ((prog-args (command-line-arguments)))
  (if (null? prog-args)
      (begin (display "usage: ./vm ROM [ARGS...]\n") (exit))
      (let* ((rom-path (car prog-args))
             (rom-args (cdr prog-args))
             (rom (open-rom rom-path))
             (start 256))
        (vector-set! dev 23 (if (null? rom-args) 0 1))
        (u:load-rom rom start)
        (u:run start)
        (u:read-args rom-args)
        (u:read-stdin (current-input-port))
        (exit 0))))