d6
/
uxn-scm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

passing opctest

This commit is contained in:
~d6 2025-01-19 19:41:54 -05:00
parent b4f7763bcc
commit d47ec098fa
1 changed files with 72 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
vm.scm
View File

@ -73,7 +73,7 @@
; push value to active stack ; push value to active stack
; uses _2, _wst, and _rst to respect instruction modes ; 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 (_push1 n) (_xpush1 _wst n))
(define (_push2 n) (_xpush2 _wst n)) (define (_push2 n) (_xpush2 _wst n))
@ -93,120 +93,128 @@
; read value from memory onto active stack ; read value from memory onto active stack
; uses _2, _wst, and _rst to respect instruction modes ; 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 (_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 ; write value to memory
; uses _2 to respect instruction modes ; uses _2 to respect instruction modes
(define (_write addr n) (define (_write addr n lim)
(if _2 (begin (if _2 (begin
(vector-set! mem addr (u16->hi n)) (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))) (vector-set! mem addr n)))
; load signed 16-bit value from memory, returning value ; load signed 16-bit value from memory, returning value
(define (_load-s16) (define (_load-s16)
(let ((hi (vector-ref mem pc)) (let ((hi (vector-ref mem pc))
(lo (vector-ref mem (+ pc 1)))) (lo (vector-ref mem (u16 (+ pc 1)))))
(s16 (hilo->u16 hi lo)))) (s16 (hilo->u16 hi lo))))
(define (restore k)
(if (null? k)
'()
(set-car! _wst k)))
; load 8 variants of an instruction ; load 8 variants of an instruction
(define (op impl s k r) (define (op impl s k r)
(lambda () (lambda ()
(set! _2 s) (set! _2 s)
(set! _wst (if r rst wst)) (set! _wst (if r rst wst))
(set! _rst (if r wst rst)) (set! _rst (if r wst rst))
(if k (impl (if k (car _wst) '()))))
(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))))
(define (jmp n) (define (jmp n)
(set! pc (if _2 n (+ pc (s8 n))))) (set! pc (if _2 n (+ pc (s8 n)))))
(define (jmpi) (define (jmi)
(set! pc (+ pc (_load-s16)))) (let ((offset (_load-s16)))
(set! pc (+ pc offset 2))))
; base instruction implementations ; base instruction implementations
; ;
; these assume that _2, _wst, and _rst are correctly set ; these assume that _2, _wst, and _rst are correctly set
; according to the instruction's mode flags. ; 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))) ; BRK, LIT, and immediate instructions ignore keep.
(define (jmi-impl) (set! pc (+ pc (_load-s16) 2))) (define (brk-impl k) (set! done #t))
(define (jsi-impl) (_rpush2 (+ pc 2)) (jmi-impl)) (define (jci-impl k) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi)))
(define (lit-impl) (_read pc) (set! pc (+ pc (if _2 2 1)))) (define (jmi-impl k) (jmi))
(define (inc-impl) (_push (+ (_pop) 1))) (define (jsi-impl k) (_rpush2 (+ pc 2)) (jmi))
(define (pop-impl) (_pop)) (define (lit-impl k) (_read pc 65536) (set! pc (+ pc (if _2 2 1))))
(define (nip-impl) (let* ((a (_pop))) (_pop) (_push a))) (define (inc-impl k) (let* ((a (_pop)) (_ (restore k))) (_push (+ a 1))))
(define (swp-impl) (let* ((b (_pop)) (a (_pop))) (_push b) (_push a))) (define (pop-impl k) (_pop) (restore k))
(define (rot-impl) (let* ((c (_pop)) (b (_pop)) (a (_pop))) (_push b) (_push c) (_push a))) (define (nip-impl k) (let* ((a (_pop)) (_ (_pop))) (restore k) (_push a)))
(define (dup-impl) (let* ((a (_pop))) (_push a) (_push a))) (define (swp-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push b) (_push a)))
(define (ovr-impl) (let* ((b (_pop)) (a (_pop))) (_push a) (_push b) (_push a))) (define (rot-impl k) (let* ((c (_pop)) (b (_pop)) (a (_pop))) (restore k) (_push b) (_push c) (_push a)))
(define (equ-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (= a b) 1 0)))) (define (dup-impl k) (let* ((a (_pop))) (restore k) (_push a) (_push a)))
(define (neq-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (not (= a b)) 0 1)))) (define (ovr-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push a) (_push b) (_push a)))
(define (gth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (> a b) 0 1)))) (define (equ-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (= a b) 1 0))))
(define (lth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (< a b) 0 1)))) (define (neq-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (= a b) 0 1))))
(define (jmp-impl) (let ((n (_pop))) (jmp n))) (define (gth-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (> a b) 1 0))))
(define (jcn-impl) (let ((n (_pop))) (if (= 0 (_pop1)) '() (jmp n)))) (define (lth-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (< a b) 1 0))))
(define (jsr-impl) (_rpush2 pc) (jmp-impl)) (define (jmp-impl k) (let ((n (_pop))) (restore k) (jmp n)))
(define (sth-impl) (_rpush (_pop))) (define (jcn-impl k) (let ((n (_pop))) (restore k) (if (= 0 (_pop1)) '() (jmp n))))
(define (ldz-impl) (_read (_pop1))) (define (jsr-impl k) (_rpush2 pc) (jmp-impl k))
(define (stz-impl) (let* ((zp (_pop1)) (n (_pop))) (_write zp n))) (define (sth-impl k) (let* ((a (_pop))) (restore k) (_rpush a)))
(define (ldr-impl) (_read (+ pc (s8 (_pop1))))) (define (ldz-impl k) (let* ((zp (_pop1))) (restore k) (_read zp 256)))
(define (str-impl) (let* ((off (_pop1)) (n (_pop))) (_write (+ pc (s8 off)) n))) (define (stz-impl k) (let* ((zp (_pop1)) (n (_pop))) (restore k) (_write zp n 256)))
(define (lda-impl) (let ((n (_pop2))) (display "! ") (display n) (display "\n") (_read n))) (define (ldr-impl k) (let* ((r (_pop1))) (restore k) (_read (+ pc (s8 r)) 65536)))
(define (sta-impl) (let* ((addr (_pop2)) (n (_pop))) (_write addr n))) (define (str-impl k) (let* ((off (_pop1)) (n (_pop))) (restore k) (_write (+ pc (s8 off)) n 65536)))
(define (add-impl) (let* ((b (_pop)) (a (_pop))) (_push (+ a b)))) (define (lda-impl k) (let ((n (_pop2))) (restore k) (_read n 65536)))
(define (sub-impl) (let* ((b (_pop)) (a (_pop))) (_push (- a b)))) (define (sta-impl k) (let* ((addr (_pop2)) (n (_pop))) (restore k) (_write addr n 65536)))
(define (mul-impl) (let* ((b (_pop)) (a (_pop))) (_push (* a b)))) (define (add-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (+ a b))))
(define (div-impl) (let* ((b (_pop)) (a (_pop))) (_push (quotient a b)))) (define (sub-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (- a b))))
(define (and-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-and a b)))) (define (mul-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (* a b))))
(define (ora-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-ior a b)))) (define (div-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (if (= b 0) 0 (quotient a b)))))
(define (eor-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-xor 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 ; DEI base instruction implementation
(define (dei-impl) (define (dei-impl k)
(let ((port (_pop1))) (let ((port (_pop1)))
(restore k)
(if _2 (if _2
(let ((hi (_dei port)) (let ((hi (_dei port))
(lo (_dei (+ port 1)))) (lo (_dei (u8 (+ port 1)))))
(_push2 (hilo->u16 hi lo))) (_push2 (hilo->u16 hi lo)))
(_push1 (_dei port))))) (_push1 (_dei port)))))
(define (_dei port) (define (_dei port)
(u8 (vector-ref dev port))) (u8 (vector-ref dev port)))
; DEO base instruction implementation ; DEO base instruction implementation
(define (deo-impl) (define (deo-impl k)
(let* ((dev (_pop1)) (n (_pop))) (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 (if _2
(begin (begin
(_deo (u16->hi n) dev) (_deo (u16->hi n) dev)
(_deo (u16->lo n) (+ dev 1))) (_deo (u16->lo n) (u8 (+ dev 1))))
(_deo n dev)))) (_deo n dev))))
(define (_deo byte port) (define (_deo byte port)
(vector-set! dev port (u8 byte)) (vector-set! dev port (u8 byte))
(cond (cond
((= 14 port) (display wst) (display "\n") (display rst) (display "\n"))
((= 24 port) (write-char (integer->char byte) (current-output-port))) ((= 24 port) (write-char (integer->char byte) (current-output-port)))
((= 25 port) (write-char (integer->char byte) (current-error-port))) ((= 25 port) (write-char (integer->char byte) (current-error-port)))
(* '()))) (* '())))
; SFT base instruction implementation ; SFT base instruction implementation
(define (sft-impl) (define (sft-impl k)
(let* ((n (_pop1)) (let* ((n (_pop1))
(a (_pop)) (a (_pop))
(left (bitwise-and (b>> n 4) 15)) (left (bitwise-and (b>> n 4) 15))
(right (bitwise-and n 15))) (right (bitwise-and n 15)))
(restore k)
(_push (b<< (b>> a right) left)))) (_push (b<< (b>> a right) left))))
; add 8 variants for a given instruction base ; add 8 variants for a given instruction base
@ -222,10 +230,10 @@
(vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr (vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr
; hardcoded instructions for base 0x00 ; hardcoded instructions for base 0x00
(vector-set! instructions 0 brk-impl) ; BRK (vector-set! instructions 0 (op brk-impl #f #f #f)) ; BRK
(vector-set! instructions 32 jci-impl) ; JCI (vector-set! instructions 32 (op jci-impl #f #f #f)) ; JCI
(vector-set! instructions 64 jmi-impl) ; JMI (vector-set! instructions 64 (op jmi-impl #f #f #f)) ; JMI
(vector-set! instructions 96 jsi-impl) ; JSI (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 128 (op lit-impl #f #f #f)) ; LIT
(vector-set! instructions 160 (op lit-impl #t #f #f)) ; LIT2 (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 192 (op lit-impl #f #f #t)) ; LITr