test.scm

   1 (import (chicken io)
   2         mars visualizer parser)
   3
   4 ;; (define addressing-test
   5 ;;   (make-prog 'at (list
   6 ;;                   (make-instr 'DAT 'F 'immediate 42 'immediate 53)
   7 ;;                   (make-instr 'DAT 'F 'immediate 123 'immediate 256)
   8 ;;                   (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
   9 ;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
  10 ;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
  11 ;;                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
  12 ;;                   (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
  13
  14 ;; (define imp
  15 ;;   (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
  16
  17 ;; (define dwarf
  18 ;;   (make-prog 'dwarf (list
  19 ;;                      (make-instr 'DAT 'F 'immediate 0 'immediate -1)
  20 ;;                      (make-instr 'ADD 'AB 'immediate 5 'direct -1)
  21 ;;                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
  22 ;;                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
  23
  24 (condition-case
  25     (vis 'destroy)
  26   ((exn) #f))
  27
  28 ;; (define files '("dwarf.red"))
  29 (define files '("imp.red" "dwarf.red"))
  30
  31 (define progs
  32   (map
  33    (lambda (fname)
  34      (string->prog (with-input-from-file fname read-string)))
  35    files))
  36
  37 (define colors '("red" "blue" "green" "magenta" "cyan"))
  38
  39 (define color-map
  40   (let loop ((entries '())
  41              (progs-left progs)
  42              (colors-left colors))
  43     (if (null? progs-left)
  44         entries
  45         (let ((this-prog (car progs-left))
  46               (this-col (car colors-left)))
  47           (loop (cons (cons (prog-name this-prog) this-col) entries)
  48                 (cdr progs-left)
  49                 (cdr colors-left))))))
  50
  51 (define vis (make-vis 640 480 8000 color-map))
  52
  53 (define core (make-core 8000 (make-instr 'DAT 'F 'immediate 0 'immediate 0)
  54                         (lambda (i n)
  55                           (vis 'update-owner i n))))
  56
  57 (define queues (install-progs core progs))
  58
  59 (for-each dump-prog progs)
  60
  61 (set! queues (run-mars core queues 10000))
  62
  63 (for-each (lambda (q)
  64             (print "Queue for " (queue-owner q) ":")
  65             (dump-queue q core)
  66             (print))
  67           queues)