passing opctest
This commit is contained in:
parent
b4f7763bcc
commit
d47ec098fa
136
vm.scm
136
vm.scm
|
|
@ -73,7 +73,7 @@
|
|||
|
||||
; push value to active stack
|
||||
; uses _2, _wst, and _rst to respect instruction modes
|
||||
(define (_push n) (if _2 (_push2 n) (_push1 n)))
|
||||
(define (_push n) (if _2 (_push2 (u16 n)) (_push1 (u8 n))))
|
||||
(define (_push1 n) (_xpush1 _wst n))
|
||||
(define (_push2 n) (_xpush2 _wst n))
|
||||
|
||||
|
|
@ -93,120 +93,128 @@
|
|||
|
||||
; 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 (_read addr lim) (if _2 (_read2 addr lim) (_read1 addr)))
|
||||
(define (_read1 addr) (_push1 (vector-ref mem addr)))
|
||||
(define (_read2 addr) (_read1 addr) (_read1 (+ addr 1)))
|
||||
(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)
|
||||
(define (_write addr n lim)
|
||||
(if _2 (begin
|
||||
(vector-set! mem addr (u16->hi n))
|
||||
(vector-set! mem (+ addr 1) (u16->lo 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 (+ pc 1))))
|
||||
(lo (vector-ref mem (u16 (+ pc 1)))))
|
||||
(s16 (hilo->u16 hi lo))))
|
||||
|
||||
(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))
|
||||
(if k
|
||||
(let ((i (car _wst)))
|
||||
(display _wst)
|
||||
(display "\n")
|
||||
(display i)
|
||||
(display "\n")
|
||||
(impl)
|
||||
(display _wst)
|
||||
(display "\n")
|
||||
(display i)
|
||||
(display "\n")
|
||||
(set-car! _wst i)
|
||||
)
|
||||
(impl))))
|
||||
(impl (if k (car _wst) '()))))
|
||||
|
||||
(define (jmp n)
|
||||
(set! pc (if _2 n (+ pc (s8 n)))))
|
||||
(define (jmpi)
|
||||
(set! pc (+ pc (_load-s16))))
|
||||
(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.
|
||||
(define (brk-impl) (set! done #t))
|
||||
(define (jci-impl) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi-impl)))
|
||||
(define (jmi-impl) (set! pc (+ pc (_load-s16) 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))) (jmp n)))
|
||||
(define (jcn-impl) (let ((n (_pop))) (if (= 0 (_pop1)) '() (jmp n))))
|
||||
(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) (let ((n (_pop2))) (display "! ") (display n) (display "\n") (_read n)))
|
||||
(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))))
|
||||
;
|
||||
; 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* ((off (_pop1)) (n (_pop))) (restore k) (_write (+ pc (s8 off)) 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)
|
||||
(define (dei-impl k)
|
||||
(let ((port (_pop1)))
|
||||
(restore k)
|
||||
(if _2
|
||||
(let ((hi (_dei port))
|
||||
(lo (_dei (+ port 1))))
|
||||
(lo (_dei (u8 (+ 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)
|
||||
(define (deo-impl k)
|
||||
(let* ((dev (_pop1)) (n (_pop)))
|
||||
(restore k)
|
||||
;; (display "deo-impl 2=")
|
||||
;; (display _2)
|
||||
;; (display " k=")
|
||||
;; (display k)
|
||||
;; (display " n=")
|
||||
;; (display n)
|
||||
;; (display " dev=")
|
||||
;; (display dev)
|
||||
;; (display "\n")
|
||||
(if _2
|
||||
(begin
|
||||
(_deo (u16->hi n) dev)
|
||||
(_deo (u16->lo n) (+ dev 1)))
|
||||
(_deo (u16->lo n) (u8 (+ dev 1))))
|
||||
(_deo n dev))))
|
||||
(define (_deo byte port)
|
||||
(vector-set! dev port (u8 byte))
|
||||
(cond
|
||||
((= 14 port) (display wst) (display "\n") (display rst) (display "\n"))
|
||||
((= 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)
|
||||
(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
|
||||
|
|
@ -222,10 +230,10 @@
|
|||
(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 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue