Finished drafting executive function instructions.

diff --git a/mars.scm b/mars.scm
index 612f20a..66ec046 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -206,38 +206,72 @@
       ((JMP)
        (list (addr+ ptr ((core-get A-ptr) 'A-num))))
       ((JMZ)
-       (list (addr+ ptr
-                    (if (case modifier
-                          ((A BA)
-                           (= 0 ((core-get A-ptr) 'A-num)))
-                          ((B AB)
-                           (= 0 ((core-get A-ptr) 'B-num)))
-                          ((X I F)
-                           (and (= 0 ((core-get A-ptr) 'A-num))
-                                (= 0 ((core-get A-ptr) 'B-num)))))
-                        ((core-get A-ptr) 'A-num)
-                        1))))
+       (list (addr+ ptr (if (instr-zero? B-ptr modifier #f)
+                            ((core-get A-ptr) 'A-num)
+                            1))))
       ((JMN)
-       (list (addr+ ptr
-                    (if (not (case modifier
-                               ((A BA)
-                                (= 0 ((core-get A-ptr) 'A-num)))
-                               ((B AB)
-                                (= 0 ((core-get A-ptr) 'B-num)))
-                               ((X I F)
-                                (and (= 0 ((core-get A-ptr) 'A-num))
-                                     (= 0 ((core-get A-ptr) 'B-num))))))
-                        ((core-get A-ptr) 'A-num)
-                        1))))
-      ((DJN))
-      ((SEQ CMP))
-      ((SNE))
-      ((SLT))
-      ((SPL))
-      ((NOP) (list (addr+ ptr 1)))
+       (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!