Default to no visualization.

[jars.git] / test.scm

diff --git a/test.scm b/test.scm
index 090c941..178260d 100644 (file)
--- a/test.scm
+++ b/test.scm
@@ -1,34 +1,67 @@
-(import mars visualizer)
+(import (chicken io)
+        mars visualizer parser)
 
-(define addressing-test
-  (make-prog 'at (list
-                  (make-instr 'DAT 'F 'immediate 42 'immediate 53)
-                  (make-instr 'DAT 'F 'immediate 123 'immediate 256)
-                  (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
-                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                  (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
+;; (define addressing-test
+;;   (make-prog 'at (list
+;;                   (make-instr 'DAT 'F 'immediate 42 'immediate 53)
+;;                   (make-instr 'DAT 'F 'immediate 123 'immediate 256)
+;;                   (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
+;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+;;                   (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
 
-(define imp
-  (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
+;; (define imp
+;;   (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
 
-(define dwarf
-  (make-prog 'dwarf (list
-                     (make-instr 'DAT 'F 'immediate 0 'immediate -1)
-                     (make-instr 'ADD 'AB 'immediate 5 'direct -1)
-                     (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
-                     (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
+;; (define dwarf
+;;   (make-prog 'dwarf (list
+;;                      (make-instr 'DAT 'F 'immediate 0 'immediate -1)
+;;                      (make-instr 'ADD 'AB 'immediate 5 'direct -1)
+;;                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
+;;                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
 
-(define palette '((imp . "red")
-                  (dwarf . "blue")))
+(condition-case
+    (vis 'destroy)
+  ((exn) #f))
 
-(define vis (make-vis 640 480 8000 palette))
+;; (define files '("dwarf.red"))
+(define files '("imp.red" "dwarf.red"))
+
+(define progs
+  (map
+   (lambda (fname)
+     (string->prog (with-input-from-file fname read-string)))
+   files))
+
+(define colors '("red" "blue" "green" "magenta" "cyan"))
+
+(define color-map
+  (let loop ((entries '())
+             (progs-left progs)
+             (colors-left colors))
+    (if (null? progs-left)
+        entries
+        (let ((this-prog (car progs-left))
+              (this-col (car colors-left)))
+          (loop (cons (cons (prog-name this-prog) this-col) entries)
+                (cdr progs-left)
+                (cdr colors-left))))))
+        
+(define vis (make-vis 640 480 8000 color-map))
 
 (define core (make-core 8000 (make-instr 'DAT 'F 'immediate 0 'immediate 0)
                         (lambda (i n)
                           (vis 'update-owner i n))))
 
-(define queues (install-progs core (list dwarf imp)))
+(define queues (install-progs core progs))
+
+(for-each dump-prog progs)
+
+(set! queues (run-mars core queues 10000))
 
-;; (run-mars core queues 10000)
+(for-each (lambda (q)
+            (print "Queue for " (queue-owner q) ":")
+            (dump-queue q core)
+            (print))
+          queues)