;; 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) (chicken time posix))
(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))
(define (get-date-time)
  (let* ((v (seconds->local-time))
         (y (vector-ref v 5)))
    (vector-set! v 5 (+ y 1900))
    v))

;; ;; 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)))
;; (define (get-date-time)
;;   (let* ((v (localtime (current-time)))
;;          (y (vector-ref v 5))
;;          (tz (vector-ref v 8)))
;;     (vector-set! v 5 (+ y 1900))
;;     (vector-set! v 8 (not (= tz 0)))
;;     v))

;; ;; 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)))
;; (define (get-date-time)
;;   (let ((t (current-date)))
;;     (vector
;;      (date-second t) (date-minute t) (date-hour t)
;;      (date-day t) (date-month t) (date-year t)
;;      (date-week-day t) (date-year-day t) (date-dst? t))))

;; === 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 (u16 n)) (_push1 (u8 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 lim) (if _2 (_read2 addr lim) (_read1 addr)))
(define (_read1 addr) (_push1 (vector-ref mem addr)))
(define (_read2 addr lim) (_read1 addr) (_read1 (modulo (+ addr 1) lim)))

;; write value to memory
;; uses _2 to respect instruction modes
(define (_write addr n lim)
  (if _2 (begin
           (vector-set! mem addr (u16->hi n))
           (vector-set! mem (modulo (+ addr 1) lim) (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 (u16 (+ pc 1)))))
    (s16 (hilo->u16 hi lo))))

;; restore a stack pointer when in keep mode
(define (restore k)
  (if (null? k)
      '()
      (set-car! _wst k)))

;; 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))
    (impl (if k (car _wst) '()))))

(define (jmp n)
  (set! pc (if _2 n (+ pc (s8 n)))))

(define (jmi)
  (let ((offset (_load-s16)))
    (set! pc (+ pc offset 2))))

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

;; DEI base instruction implementation
(define (dei-impl k)
  (let ((port (_pop1)))
    (restore k)
    (if _2
        (let ((hi (_dei port))
              (lo (_dei (u8 (+ port 1)))))
          (_push2 (hilo->u16 hi lo)))
        (_push1 (_dei port)))))
(define (_dei port)
  (cond
   ((= 4 port) (_push1 (+ (car wst) 1)))
   ((= 5 port) (_push1 (+ (car rst) 1)))
   ((and (<= 192 port) (< port 208)) (_datetime (- port 192)))
   (* (u8 (vector-ref dev port)))))

;; (0:seconds 1:minutes 2:hours 3:mday 4:month 5:year 6:wday 7:yday 8:dstflag 9:timezone)
(define (_datetime field)
  (u8 (let ((t (get-date-time)))
        (cond
         ((= field 0) (u16->hi (vector-ref t 5))) ; year hi
         ((= field 1) (u16->lo (vector-ref t 5))) ; year lo
         ((= field 2) (vector-ref t 4))           ; month
         ((= field 3) (vector-ref t 3))           ; day of month
         ((= field 4) (vector-ref t 2))           ; hours
         ((= field 5) (vector-ref t 1))           ; minutes
         ((= field 6) (vector-ref t 0))           ; seconds
         ((= field 7) (vector-ref t 6))           ; day of week
         ((= field 8) (u16->hi (vector-ref t 7))) ; day of year hi
         ((= field 9) (u16->lo (vector-ref t 7))) ; day of year lo
         ((= field 10) (if (vector-ref t 8) 1 0)) ; is dst
         (* (vector-ref dev (+ 192 field)))))))   ; device memory

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

(define (u:debug)
  (u:debug-stack "WST" wst) (u:debug-stack "RST" rst))

(define (u:debug-stack label st)
  (display label)
  (u:debug-cells (cdr st) (u8 (- (car st) 8)) (car st) (current-output-port)))

(define (u:debug-cells cells i limit port)
  (display (if (= i 0) "|" " ") port)
  (if (= i limit) (display "<\n")
      (begin
        (emit-u8 (vector-ref cells i) port)
        (u:debug-cells cells (u8 (+ i 1)) limit port))))

(define (emit-u8 n port)
  (display (number->string (quotient n 16) 16) port)
  (display (number->string (modulo n 16) 16) port))

;; SFT base instruction implementation
(define (sft-impl k)
  (let* ((n (_pop1))
         (a (_pop))
         (left (bitwise-and (b>> n 4) 15))
         (right (bitwise-and n 15)))
    (restore k)
    (_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 #f #t #t))  ; -kr
  (vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr

;; hardcoded instructions for base 0x00
(vector-set! instructions 0 (op brk-impl #f #f #f))   ; BRK
(vector-set! instructions 32 (op jci-impl #f #f #f))  ; JCI
(vector-set! instructions 64 (op jmi-impl #f #f #f))  ; JMI
(vector-set! instructions 96 (op jsi-impl #f #f #f))  ; 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)))
        (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, or end of stdin
(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)
        (u:send-input #\newline 4)
        (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)
        (if (null? rom-args) '() (u:read-args rom-args))
        (u:read-stdin (current-input-port))
        (exit 0))))