; basic varvara emulator implementation in scheme
;
; does not currently use any macros or advanced features.
; first stanza defines non-portable bit-related functions.

; implementation-dependent features which differ between scheme impls

; chicken scheme
(import chicken.bitwise)
(define (b-and x y) (bitwise-and x y))
(define (b-or x y) (bitwise-ior x y))
(define (b-xor x y) (bitwise-xor x y))
(define (b<< n s) (arithmetic-shift n s))
(define (b>> n s) (arithmetic-shift n (- s)))
(define (b-read-u8 port) (u8 (char->integer (read-char port))))

;; ; guile
;; (use-modules (srfi srfi-60))
;; (use-modules (ice-9 binary-ports))
;; (define (b-and x y) (bitwise-and x y))
;; (define (b-or x y) (bitwise-ior x y))
;; (define (b-xor x y) (bitwise-xor x y))
;; (define (b<< n s) (arithmetic-shift n s))
;; (define (b>> n s) (arithmetic-shift n (- s)))
;; (define (b-read-u8 port) (u8 (get-u8 port)))

; portable scheme code follows

; global state for the virtual machine
(define instructions (make-vector 256 (lambda () (display "!!! no instruction\n"))))
(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))

; convert a cons cell of two bytes to one short
; (0 . 0) -> 0
; (1 . 1) -> 257
; (2 . 2) -> 514
(define (join-u16 parts)
  (let ((hi (car parts))
        (lo (cdr parts)))
    (+ (* 256 hi) lo)))

; convert a short to a cons cell of two bytes
; 12 -> (0 . 12)
; 257 -> (1 . 1)
(define (tear-u16 n)
  (let ((n2 (modulo n 256))
        (n1 (floor (/ n 256))))
    (cons n1 n2)))

; 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* ((hi (_pop1))
         (lo (_pop1)))
    (join-u16 (cons 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) (_rpush1 n)))
(define (_rpush1 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)
  (let ((parts (tear-u16 n)))
    (_xpush1 st (car parts))
    (_xpush1 st (cdr parts))))

; 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 (_write2 addr n) (_write1 addr n)))
(define (_write1 addr n)
  (vector-set! mem addr n))
(define (_write2 addr n)
  (let ((parts (tear-u16 n)))
    (vector-set! mem addr (car parts))
    (vector-set! mem (+ addr 1) (cdr parts))))

; load signed 16-bit value from memory, returning value
(define (_load-s16)
  (let ((hi (vector-ref mem (+ pc 1)))
        (lo (vector-ref mem (+ pc 2))))
    (s16 (join-u16 (cons 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 1)) (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 (b-and a b))))
(define (ora-impl) (let ((b (_pop)) (a (_pop))) (_push (b-or a b))))
(define (eor-impl) (let ((b (_pop)) (a (_pop))) (_push (b-xor a b))))

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

; DEO base instruction implementation
(define (deo-impl)
  (let ((dev (_pop1)) (n (_pop)))
    (if _2
        (let ((parts (tear-u16 n)))
          (_deo (car parts) dev)
          (_deo (cdr parts) (+ 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 (b-and (b>> n 4) 15))
        (right (b-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)))
        (fn)
        (set! pc (+ pc 1))
        (u:eval))))

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

; load the rom and begin evaluation
(let ((rom (open-input-file "hello.rom")))
  (u:load-rom rom 256)
  (u:eval))