X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=mars.scm;h=9610d10c791c47f08480589e484a1c285759f899;hp=23a0337df4e4d75e88aa49eda6df3a6f9c2f7980;hb=7526b1f66f4c7a0d460d0e267b1eb4553c0d981b;hpb=6fa8a83fb4cf917fabe4c2bb930b8b092c9c7519

diff --git a/mars.scm b/mars.scm
index 23a0337..9610d10 100644
--- a/mars.scm
+++ b/mars.scm
@@ -9,10 +9,12 @@
      prog-instrs
      prog-offset
      prog->string
+     dump-prog
      install-progs
      make-queue
      queue-owner
      queue-ptrs
+     dump-queue
      make-core
      run-mars)
 
@@ -55,7 +57,7 @@
         (('->string)
          (conc opcode
                "." modifier
-               " " (mode->string A-mode) A-num
+               "\t" (mode->string A-mode) A-num
                ", " (mode->string B-mode) B-num))
         (else
          (error "Invalid instr arguments" args)))))
@@ -95,6 +97,12 @@
         (let loop ((remaining-fns set-functions))
           (unless (null? remaining-fns)
             ((car remaining-fns) i n))))
+      (define (dump i)
+        (print* i ":\t" ((norm-ref core-vec i) '->string))
+        (let ((n (norm-ref names-vec i)))
+          (unless (null? n)
+            (print* "\t;" n)))
+        (print))
       (let loop ((i 0))
         (unless (>= i core-size)
           (vector-set! core-vec i (initial-instr 'make-copy))
@@ -116,27 +124,28 @@
           ((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)
-               (print* i ":\t" ((vector-ref core-vec i) '->string))
-               (let ((n (vector-ref names-vec i)))
-                 (unless (null? n)
-                   (print* "\t;" n)))
-               (print)
-               (loop (+ i 1)))))
+          (('dump i)
+           (let ((i1 (- i 4))
+                 (i2 (+ i 4)))
+             (let loop ((idx i1))
+               (unless (> idx i2)
+                 (if (= idx i)
+                     (print* "*"))
+                 (dump idx)
+                 (loop (+ idx 1))))))
           (('size) core-size)))))
 
 
   ;;; Programmes and task queues
   ;;
 
-  (define (make-prog name instrs offset)
-    (list name instrs offset))
+  (define (make-prog name author instrs offset)
+    (list name author instrs offset))
 
   (define (prog-name prog) (list-ref prog 0))
-  (define (prog-instrs prog) (list-ref prog 1))
-  (define (prog-offset prog) (list-ref prog 2))
+  (define (prog-author prog) (list-ref prog 1))
+  (define (prog-instrs prog) (list-ref prog 2))
+  (define (prog-offset prog) (list-ref prog 3))
 
   (define (install-prog core prog addr)
     (let loop ((ptr addr)
@@ -178,11 +187,24 @@
   (define (queue-set-ptrs! queue ptrs)
     (set-cdr! queue ptrs))
 
+  (define (dump-queue queue core)
+    (let loop ((ptrs (queue-ptrs queue)))
+      (unless (null? ptrs)
+        (core 'dump (car ptrs))
+        (print)
+        (loop (cdr ptrs)))))
+
   (define (prog->string prog)
     (conc ";redcode\n\n"
-          ";name " (prog-name prog) "\n\n"
+          ";name\t" (prog-name prog) "\n"
+          (if (not (null? (prog-author prog)))
+              (conc ";author\t" (prog-author prog) "\n\n")
+              "\n")
           "ORG\t" (prog-offset prog) "\t; Execution offset\n\n"
           (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog)))))
+
+  (define (dump-prog prog)
+    (print (prog->string prog)))
     
   ;;; Executive function
   ;;
@@ -190,19 +212,20 @@
   (define (run-mars core queues steps-left)
     (cond
      ((<= steps-left 0) queues)      ;Tie between remaining players
-     ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
+     ((null? queues) queues)         ;Everyone's dead
      (else
       (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 remaining-queues (- steps-left 1))
+            (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 ")")
     (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
            (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
            (modifier (core ptr 'modifier)))
@@ -237,19 +260,19 @@
                (list (core '->addr (+ ptr 1))))
            ((exn arithmetic) '())))
         ((JMP)
-         (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
+         (list (core '->addr A-ptr)))
         ((JMZ)
-         (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
-                                        (core A-ptr 'A-num)
-                                        1)))))
+         (list (core '->addr (if (instr-zero? B-ptr modifier #f name)
+                                 A-ptr
+                                 (+ ptr 1)))))
         ((JMN)
-         (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
-                                        (core A-ptr 'A-num)
-                                        1)))))
+         (list (core '->addr (if (not (instr-zero? B-ptr modifier #f name))
+                                 A-ptr
+                                 (+ ptr 1)))))
         ((DJN)
-         (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
-                                        (core A-ptr 'A-num)
-                                        1)))))
+         (list (core '->addr (if (not (instr-zero? B-ptr modifier #t name))
+                                 A-ptr
+                                 (+ ptr 1)))))
         ((SEQ CMP)
          (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
         ((SNE)
@@ -257,7 +280,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 (+ ptr (core A-ptr 'A-num))))))
+         (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
         ((NOP)
          (list (core '->addr (+ ptr 1))))
         (else