Removed addr+ procedure.

diff --git a/mars.scm b/mars.scm
index df9aab6..e76a032 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -67,6 +67,17 @@
 (define (make-core core-size initial-instr)
   (let ((core-vec (make-vector core-size '()))
         (names-vec (make-vector core-size '())))
+    (define (norm-addr i)
+      (if (< i 0)
+          (norm-addr (+ i core-size))
+          (modulo i core-size)))
+    (define (norm-ref v i)
+      (vector-ref v (norm-addr i)))
+    (define (norm-set! v i x)
+      (vector-set! v (norm-addr i)
+                   (if (integer? x)
+                       (norm-addr x)
+                       x)))
     (let loop ((i 0))
       (unless (>= i core-size)
         (vector-set! core-vec i (initial-instr 'make-copy))
@@ -74,16 +85,17 @@
     (lambda args
       (match args
         ((i 'set-from! j n)
-         ((vector-ref core-vec i) 'set-from! (vector-ref core-vec j))
-         (vector-set! names-vec i n))
+         ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j))
+         (norm-set! names-vec i n))
         ((i 'set-from-instr! instr n)
-         ((vector-ref core-vec i) 'set-from! instr)
-         (vector-set! names-vec i n))
+         ((norm-ref core-vec i) 'set-from! instr)
+         (norm-set! names-vec i n))
         ((i 'set! v x n)
-         ((vector-ref core-vec i) 'set! v x)
-         (vector-set! names-vec i n))
-        ((i 'name) (vector-ref names-vec i))
-        ((i v) ((vector-ref core-vec i) v))
+         ((norm-ref core-vec i) 'set! v x)
+         (norm-set! names-vec i n))
+        ((i 'name) (norm-ref names-vec i))
+        (((? integer? i) v) ((norm-ref core-vec i) v))
+        (('->addr (? integer? i)) (norm-addr i))
         (('dump)
          (let loop ((i 0))
            (unless (>= i core-size)
@@ -92,12 +104,9 @@
                (unless (null? n)
                  (print* "\t;" n)))
              (print)
-             (loop (+ i 1)))))))))
+             (loop (+ i 1)))))
+        (('size) core-size)))))
 
-(define (addr+ . args)
-  (foldl (lambda (a b)
-           (modulo (+ a b core-size) core-size))
-         0 args))
 
 ;;; Programmes and task queues
 ;;
@@ -114,9 +123,9 @@
              (instrs (prog-instrs prog)))
     (unless (null? instrs)
       (core ptr 'set-from-instr! (car instrs) (prog-name prog))
-      (loop (addr+ ptr 1) (cdr instrs))))
+      (loop (core '->addr (+ ptr 1)) (cdr instrs))))
   (make-queue (prog-name prog)
-              (addr+ addr (prog-offset prog))))
+              (core '->addr (+ addr (prog-offset prog)))))
 
 (define (can-install-prog? core prog-len addr)
   (let loop ((ptr addr)
@@ -124,7 +133,7 @@
     (if (= remaining 0)
         #t
         (if (null? (core ptr 'name))
-            (loop (addr+ ptr 1)
+            (loop (core '->addr (+ ptr 1))
                   (- remaining 1))
             #f))))
 
@@ -133,7 +142,7 @@
              (progs-left progs))
     (if (null? progs-left)
         queues
-        (let ((addr (pseudo-random-integer core-size))
+        (let ((addr (pseudo-random-integer (core 'size)))
               (prog (car progs-left)))
           (if (can-install-prog? core (length (prog-instrs prog)) addr)
               (loop (cons (install-prog core prog addr) queues)
@@ -179,60 +188,53 @@
        (if (eq? modifier 'I)
            (core B-ptr 'set-from! A-ptr name)
            (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
-       (list (addr+ ptr 1)))
+       (list (core '->addr (+ ptr 1))))
       ((ADD)
-       (combine-and-store core A-ptr B-ptr modifier name addr+)
-       (list (addr+ ptr 1)))
+       (combine-and-store core A-ptr B-ptr modifier name +)
+       (list (core '->addr (+ ptr 1))))
       ((SUB)
-       (combine-and-store core A-ptr B-ptr modifier name
-                          (lambda (x y) (addr+ x (- y))))
-       (list (addr+ ptr 1)))
+       (combine-and-store core A-ptr B-ptr modifier name -)
+       (list (core '->addr (+ ptr 1))))
       ((MUL)
-       (combine-and-store core A-ptr B-ptr modifier name
-                          (lambda (x y) (modulo (* (addr+ x core-size)
-                                                   (addr+ y core-size))
-                                                core-size)))
-       (list (addr+ ptr 1)))
+       (combine-and-store core A-ptr B-ptr modifier name *)
+       (list (core '->addr (+ ptr 1))))
       ((DIV)
        (condition-case 
            (begin
-             (combine-and-store core A-ptr B-ptr modifier name
-                                (lambda (x y) (quotient (addr x core-size)
-                                                        (addr y core-size))))
-             (list (addr+ ptr 1)))
+             (combine-and-store core A-ptr B-ptr modifier name quotient)
+                                
+             (list (core '->addr (+ ptr 1))))
          ((exn arithmetic) '())))
       ((MOD)
        (condition-case
            (begin
-             (combine-and-store core A-ptr B-ptr modifier name
-                                (lambda (x y) (remainder (addr x core-size)
-                                                         (addr y core-size))))
-             (list (addr+ ptr 1)))
+             (combine-and-store core A-ptr B-ptr modifier name modulo)
+             (list (core '->addr (+ ptr 1))))
          ((exn arithmetic) '())))
       ((JMP)
-       (list (addr+ ptr (core A-ptr 'A-num))))
+       (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
       ((JMZ)
-       (list (addr+ ptr (if (instr-zero? B-ptr modifier #f name)
-                            (core A-ptr 'A-num)
-                            1))))
+       (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
+                                      (core A-ptr 'A-num)
+                                      1)))))
       ((JMN)
-       (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f name))
-                            (core A-ptr 'A-num)
-                            1))))
+       (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
+                                      (core A-ptr 'A-num)
+                                      1)))))
       ((DJN)
-       (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t name))
-                            (core A-ptr 'A-num)
-                            1))))
+       (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
+                                      (core A-ptr 'A-num)
+                                      1)))))
       ((SEQ CMP)
-       (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1))))
+       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
       ((SNE)
-       (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2))))
+       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
       ((SLT)
-       (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1))))
+       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
       ((SPL)
-       (list (addr+ ptr 1) (addr+ ptr (core A-ptr 'A-num))))
+       (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num))))))
       ((NOP)
-       (list (addr+ ptr 1)))
+       (list (core '->addr (+ ptr 1))))
       (else
        (error "Unrecognised opcode" (instr 'opcode))))))
 
@@ -262,16 +264,16 @@
 (define (instr-zero? core ptr modifier decrement name)
   (case modifier
     ((A AB)
-     (if decrement (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name))
+     (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
      (= 0 (core ptr 'A-num)))
     ((A AB)
-     (if decrement (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name))
+     (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
      (= 0 (core ptr 'B-num)))
     ((X I F)
      (if decrement
          (begin
-           (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name)
-           (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name)))
+           (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
+           (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
      (and (= 0 (core ptr 'A-num))
           (= 0 (core ptr 'B-num))))))
 
@@ -295,32 +297,32 @@
                (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
 
 (define (eval-operand core mode num ptr name)
-  (addr+ ptr
-         (case mode
-           ((immediate) 0)
-           ((direct) num)
-           ((indirect-A) (addr+ num (core (addr+ ptr num) 'A-num)))
-           ((indirect-B) (addr+ num (core (addr+ ptr num) 'B-num)))
-           ((pre-indirect-A)
-            (let ((aux-ptr (addr+ ptr num)))
-              (core aux-ptr 'set! 'A-num (addr+ -1 (core aux-ptr 'A-num)) name)
-              (addr+ num (core aux-ptr 'A-num))))
-           ((pre-indirect-B)
-            (let ((aux-ptr (addr+ ptr num)))
-              (core aux-ptr 'set! 'B-num (addr+ -1 (core aux-ptr 'B-num)) name)
-              (addr+ num (core aux-ptr 'B-num))))
-           ((post-indirect-A)
-            (let* ((aux-ptr (addr+ ptr num))
-                   (old-A-num (core aux-ptr 'A-num)))
-              (core aux-ptr 'set! 'A-num (addr+ 1 (core aux-ptr 'A-num)) name)
-              (addr+ num old-A-num)))
-           ((post-indirect-B)
-            (let* ((aux-ptr (addr+ ptr num))
-                   (old-B-num (core aux-ptr 'B-num)))
-              (core aux-ptr 'set! 'B-num (addr+ 1 (core aux-ptr 'B-num)) name)
-              (addr+ num old-B-num)))
-           (else
-            (error "Unrecognized mode" mode)))))
+  (core '->addr (+ ptr
+                   (case mode
+                     ((immediate) 0)
+                     ((direct) num)
+                     ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
+                     ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
+                     ((pre-indirect-A)
+                      (let ((aux-ptr (+ ptr num)))
+                        (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
+                        (+ num (core aux-ptr 'A-num))))
+                     ((pre-indirect-B)
+                      (let ((aux-ptr (+ ptr num)))
+                        (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
+                        (+ num (core aux-ptr 'B-num))))
+                     ((post-indirect-A)
+                      (let* ((aux-ptr (+ ptr num))
+                             (old-A-num (core aux-ptr 'A-num)))
+                        (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
+                        (+ num old-A-num)))
+                     ((post-indirect-B)
+                      (let* ((aux-ptr (+ ptr num))
+                             (old-B-num (core aux-ptr 'B-num)))
+                        (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
+                        (+ num old-B-num)))
+                     (else
+                      (error "Unrecognized mode" mode))))))
 
 ;;; Main procedure
 ;;