From d47ec098faf4461b00b3e28ffdae05dfb7d3b58c Mon Sep 17 00:00:00 2001
From: d_m <d_m@plastic-idolatry.com>
Date: Sun, 19 Jan 2025 19:41:54 -0500
Subject: [PATCH] passing opctest

---
 vm.scm | 136 ++++++++++++++++++++++++++++++---------------------------
 1 file changed, 72 insertions(+), 64 deletions(-)

diff --git a/vm.scm b/vm.scm
index e1c496f..87aa547 100644
--- a/vm.scm
+++ b/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