X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=mars.scm;h=66ec04689749457b5c9a9185cb9b6aeea0c0d1fc;hp=39133d25cfbf816f13a8b2b2817d83e864052b80;hb=872b5d3c7e9bd01466a343336c61f51a837e278f;hpb=e676d3621cc68b3fab125b320c8c5efeaf892527

diff --git a/mars.scm b/mars.scm
index 39133d2..66ec046 100644
--- a/mars.scm
+++ b/mars.scm
@@ -205,17 +205,73 @@
          ((exn arithmetic) '())))
       ((JMP)
        (list (addr+ ptr ((core-get A-ptr) 'A-num))))
-      ((JMZ))
-      ((JMN))
-      ((DJN))
-      ((SEQ CMP))
-      ((SNE))
-      ((SLT))
-      ((SPL))
-      ((NOP) (list (addr+ ptr 1)))
+      ((JMZ)
+       (list (addr+ ptr (if (instr-zero? B-ptr modifier #f)
+                            ((core-get A-ptr) 'A-num)
+                            1))))
+      ((JMN)
+       (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f)
+                                 ((core-get A-ptr) 'A-num)
+                                 1)))))
+      ((DJN)
+       (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t)
+                                 ((core-get A-ptr) 'A-num)
+                                 1)))))
+      ((SEQ CMP)
+       (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 2 1))))
+      ((SNE)
+       (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 1 2))))
+      ((SLT)
+       (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier <) 2 1))))
+      ((SPL)
+       (list (addr+ ptr 1) (addr+ ptr ((core-get A-ptr) 'A-num))))
+      ((NOP)
+       (list (addr+ ptr 1)))
       (else
        (error "Unrecognised opcode" (instr 'opcode))))))
 
+(define (compare-instrs A-ptr B-ptr modifier test)
+  (let ((A-instr (core-get A-ptr))
+        (B-instr (core-get B-ptr)))
+    (case modifier
+      ((A) (test (A-instr 'A-num) (B-instr 'A-num)))
+      ((B) (test (A-instr 'B-num) (B-instr 'B-num)))
+      ((AB) (test (A-instr 'A-num) (B-instr 'B-num)))
+      ((BA) (test (A-instr 'B-num) (B-instr 'A-num)))
+      ((F) (and
+            (test (A-instr 'A-num) (B-instr 'A-num))
+            (test (A-instr 'B-num) (B-instr 'B-num))))
+      ((X) (and
+            (test (A-instr 'A-num) (B-instr 'B-num))
+            (test (A-instr 'B-num) (B-instr 'A-num))))
+      ((I) (and
+            (if (eq? test =)
+                (and
+                 (eq? (A-instr 'opcode) (B-instr 'opcode))
+                 (eq? (A-instr 'modifier) (B-instr 'modifier))
+                 (eq? (A-instr 'A-mode) (B-instr 'B-mode))
+                 (eq? (A-instr 'B-mode) (B-instr 'A-mode)))
+                #t)
+            (test (A-instr 'A-num) (B-instr 'B-num))
+            (test (A-instr 'B-num) (B-instr 'A-num)))))))
+
+(define (instr-zero? ptr modifier decrement)
+  (let ((instr (core-get ptr)))
+    (case modifier
+      ((A AB)
+       (if decrement (instr 'set-A-num! (addr+ (instr 'A-num) -1)))
+       (= 0 (instr 'A-num)))
+      ((A AB)
+       (if decrement (instr 'set-B-num! (addr+ (instr 'B-num) -1)))
+       (= 0 (instr 'B-num)))
+      ((X I F)
+       (if decrement
+           (begin
+             (instr 'set-A-num! (addr+ (instr 'A-num) -1))
+             (instr 'set-B-num! (addr+ (instr 'B-num) -1))))
+       (and (= 0 (instr 'A-num))
+            (= 0 (instr 'B-num)))))))
+
 (define (combine-and-store A-ptr B-ptr modifier name f)
   (case modifier
     ((A) ((core-get B-ptr) 'set-A-num!
@@ -244,21 +300,21 @@
            ((indirect-B) (addr+ num ((core-get (addr+ ptr num)) 'B-num)))
            ((pre-indirect-A)
             (let ((aux-instr (core-get (addr+ ptr num))))
-              (instr-set-A-num! aux-instr (addr+ -1 (aux-instr 'A-num)))
+              ((aux-instr set-A-num! (addr+ -1 (aux-instr 'A-num))))
               (addr+ num (aux-instr 'A-num))))
            ((pre-indirect-B)
             (let ((aux-instr (core-get (addr+ ptr num))))
-              (instr-set-B-num! aux-instr (addr+ -1 (aux-instr 'B-num)))
+              (aux-instr set-B-num!(addr+ -1 (aux-instr 'B-num)))
               (addr+ num (aux-instr 'B-num))))
            ((post-indirect-A)
             (let* ((aux-instr (core-get (addr+ ptr num)))
                    (old-A-num (aux-instr 'A-num)))
-              (instr-set-A-num! aux-instr (addr+ 1 (aux-instr 'A-num)))
+              (aux-instr set-A-num! (addr+ 1 (aux-instr 'A-num)))
               (addr+ num old-A-num)))
            ((post-indirect-B)
             (let* ((aux-instr (core-get (addr+ ptr num)))
                    (old-B-num (aux-instr 'B-num)))
-              (instr-set-B-num! aux-instr (addr+ 1 (aux-instr 'B-num)))
+              (aux-instr set-B-num! (addr+ 1 (aux-instr 'B-num)))
               (addr+ num old-B-num)))
            (else
             (error "Unrecognized mode" mode)))))