Easier debugging of MARS.

[jars.git] / mars.scm

diff --git a/mars.scm b/mars.scm
index 3ead51f..ae70c88 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -6,6 +6,7 @@
     (make-instr
      make-prog
      prog-name
+     prog-author
      prog-instrs
      prog-offset
      prog->string
@@ -79,7 +80,9 @@
   ;;; Memory setup and addressing
   ;;
 
-  (define (make-core core-size initial-instr . set-functions)
+  (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
+
+  (define (make-core core-size . set-functions)
     (let ((core-vec (make-vector core-size '()))
           (names-vec (make-vector core-size '())))
       (define (norm-addr i)
@@ -105,7 +108,7 @@
         (print))
       (let loop ((i 0))
         (unless (>= i core-size)
-          (vector-set! core-vec i (initial-instr 'make-copy))
+          (vector-set! core-vec i (INITIAL-INSTR 'make-copy))
           (loop (+ i 1))))
       (lambda args
         (match args
@@ -210,20 +213,20 @@
   ;;; Executive function
   ;;
 
-  (define (run-mars core queues steps-left)
-    (if (or (<= steps-left 0)
-            (null? queues)
-            (= (length queues) 1))
-        queues
-        (let* ((queue (car queues))
-               (remaining-queues (cdr queues))
-               (ptrs (queue-ptrs queue))
-               (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
-          (if (null? new-ptrs)
-              (run-mars core remaining-queues (- steps-left 1))
-              (begin
-                (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
-                (run-mars core (append remaining-queues (list queue)) (- steps-left 1)))))))
+  (define (run-mars core queues steps-left . rest)
+    (let ((min-queue-count (if (null? rest) 2 (car rest))))
+      (if (or (<= steps-left 0)
+              (< (length queues) min-queue-count))
+          queues
+          (let* ((queue (car queues))
+                 (remaining-queues (cdr queues))
+                 (ptrs (queue-ptrs queue))
+                 (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
+            (if (null? new-ptrs)
+                (run-mars core remaining-queues (- steps-left 1))
+                (begin
+                  (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
+                  (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
 
   (define (execute-instr core ptr name)
     ;; (print ptr "\t" (core ptr '->string) "\t(" name ")")
@@ -281,7 +284,7 @@
         ((SLT)
          (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
         ((SPL)
-         (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
+         (list (core '->addr (+ ptr 1)) (core '->addr A-ptr)))
         ((NOP)
          (list (core '->addr (+ ptr 1))))
         (else