This is too adictive.

diff --git a/dwarf.red b/dwarf.red
new file mode 100644 (file)
index 0000000..d0abecb
--- /dev/null
+++ b/dwarf.red
@@ -0,0 +1,17 @@
+;redcode
+
+;name          Dwarf
+;author        A. K. Dewdney
+;version       94.1
+;date          April 29, 1993
+
+;strategy      Bombs every fourth instruction.
+;assert        CORESIZE % 4 == 0
+
+ORG     1          ; Indicates execution begins with the second
+; instruction (ORG is not actually loaded, and is
+
+DAT.F   #0, #0     ; Pointer to target instruction.
+ADD.AB  #4, $-1    ; Increments pointer by step.
+MOV.AB  #0, @-2    ; Bombs target instruction.
+JMP.A   $-2, #0    ; Loops back two instructions.

diff --git a/imp.red b/imp.red
new file mode 100644 (file)
index 0000000..4ef2cc1
--- /dev/null
+++ b/imp.red
@@ -0,0 +1,6 @@
+;redcode
+
+;name Imp
+
+ORG 0
+MOV.I $0, $1

diff --git a/mars.scm b/mars.scm
index 40e4ca1..23a0337 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -8,6 +8,7 @@
      prog-name
      prog-instrs
      prog-offset
+     prog->string
      install-progs
      make-queue
      queue-owner
@@ -55,7 +56,7 @@
          (conc opcode
                "." modifier
                " " (mode->string A-mode) A-num
-               " " (mode->string B-mode) B-num))
+               ", " (mode->string B-mode) B-num))
         (else
          (error "Invalid instr arguments" args)))))
 
@@ -177,7 +178,12 @@
   (define (queue-set-ptrs! queue ptrs)
     (set-cdr! queue ptrs))
 
-
+  (define (prog->string prog)
+    (conc ";redcode\n\n"
+          ";name " (prog-name prog) "\n\n"
+          "ORG\t" (prog-offset prog) "\t; Execution offset\n\n"
+          (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog)))))
+    
   ;;; Executive function
   ;;
 

diff --git a/parse.scm b/parse.scm
deleted file mode 100644 (file)
index c2bec6a..0000000
--- a/parse.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-(import (chicken irregex))
-
-(define (string->instr str)
-  (let ((idx 0)
-        (l (string-length str))
-        (whitespace-irx (irregex "[ \t]*"))
-        (newline-irx (irregex "\n"))
-        (comment-irx (irregex ";[^\n]*")))
-    (define (accept-token irx mandatory)
-      (let ((wsmatch (irregex-match whitespace-irx (substr str idx))))
-        (set! idx (+ idx (irregex-match-end-index wsmatch)))) ;Skip leading whitespace
-      (let ((res (irregex-match irx (substring str idx))))
-        (if res
-            (begin
-              (set! idx (+ idx (irregex-match-end-index res)))
-              (irregex-match-substring res))
-            (if mandatory
-                (error "Unexpected token at input string index" idx)
-                #f))))
-    (define (accept-token-string token-str mandatory)
-      (accept-token (irregex token-str) mandatory))
-    (define (load-file)
-      (let loop ()
-        (if (line)
-            (loop))))
-    (define (line)
-      (or (accept-token comment-irx #f)
-          (accept-token newline-irx #f)
-          (and(accept-token newline-irx #t))))
-    (define (instruction)
-      (and (opcode)
-           (accept-token period-irx #t)
-           (accept-modifier)))))
-               

diff --git a/parser.scm b/parser.scm
new file mode 100644 (file)
index 0000000..11491b7
--- /dev/null
+++ b/parser.scm
@@ -0,0 +1,174 @@
+(module parser
+    (string->prog)
+
+  (import scheme
+          (chicken base)
+          (chicken irregex)
+          (chicken io)
+          (chicken string)
+          mars)
+
+  (define (string->prog str)
+    (let ((idx 0)
+          (l (string-length str))
+          (whitespace-irx (irregex "^[ \t]+"))
+          (newline-irx (irregex "^\n"))
+          (comma-irx (irregex "^,"))
+          (period-irx (irregex "^\\."))
+          (redcode-irx (irregex "^;redcode\n"))
+          (name-start-irx (irregex "^;[ \t]*name "))
+          (name-irx (irregex "^[a-zA-Z0-9]+"))
+          (comment-irx (irregex "^(;[^\n]*)?\n"))
+          (org-irx (irregex "^ORG"))
+          (opcode-DAT-irx (irregex "^DAT"))
+          (opcode-MOV-irx (irregex "^MOV"))
+          (opcode-ADD-irx (irregex "^ADD"))
+          (opcode-SUB-irx (irregex "^SUB"))
+          (opcode-MUL-irx (irregex "^MUL"))
+          (opcode-DIV-irx (irregex "^DIV"))
+          (opcode-MOD-irx (irregex "^MOD"))
+          (opcode-JMP-irx (irregex "^JMP"))
+          (opcode-JMZ-irx (irregex "^JMZ"))
+          (opcode-JMN-irx (irregex "^JMN"))
+          (opcode-DMN-irx (irregex "^JMN"))
+          (opcode-DJN-irx (irregex "^DJN"))
+          (opcode-CMP-irx (irregex "^CMP"))
+          (opcode-SEQ-irx (irregex "^SEQ"))
+          (opcode-SNE-irx (irregex "^SNE"))
+          (opcode-SLT-irx (irregex "^SLT"))
+          (opcode-SPL-irx (irregex "^SPL"))
+          (opcode-NOP-irx (irregex "^NOP"))
+          (modifier-A-irx (irregex "^A"))
+          (modifier-B-irx (irregex "^B"))
+          (modifier-AB-irx (irregex "^AB"))
+          (modifier-BA-irx (irregex "^BA"))
+          (modifier-F-irx (irregex "^F"))
+          (modifier-X-irx (irregex "^X"))
+          (modifier-I-irx (irregex "^I"))
+          (mode-immediate-irx (irregex "^#"))
+          (mode-direct-irx (irregex "^\\$"))
+          (mode-indirect-A-irx (irregex "^\\*"))
+          (mode-indirect-B-irx (irregex "^@"))
+          (mode-pre-indirect-A-irx (irregex "^\\{"))
+          (mode-pre-indirect-B-irx (irregex "^<"))
+          (mode-post-indirect-A-irx (irregex "^\\}"))
+          (mode-post-indirect-B-irx (irregex "^>"))
+          (number-irx (irregex "^(\\+|-)?[0-9]+")))
+      (define (accept-token irx . rest)
+        (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
+          (if wsmatch
+              (set! idx (+ idx (irregex-match-end-index wsmatch))))) ;Skip leading whitespace
+        (let ((mandatory (and (= (length rest) 1) (car rest)))
+              (res (irregex-search irx (substring str idx))))
+          (if res
+              (begin
+                (set! idx (+ idx (irregex-match-end-index res)))
+                (irregex-match-substring res))
+              (if mandatory
+                  (error "Unexpected token at input string index" idx)
+                  #f))))
+      (define (load-file)
+        (accept-token redcode-irx #t)
+        (let loop ((instrs '())
+                   (offset 0)
+                   (name '()))
+          (let ((this-line (line)))
+            (if this-line
+                (case (car this-line)
+                  ((name) (loop instrs offset (cdr this-line)))
+                  ((comment) (loop instrs offset name))
+                  ((org) (loop instrs (cdr this-line) name))
+                  ((instr) (loop (cons (cdr this-line) instrs) offset name)))
+                (make-prog name (reverse instrs) offset)))))
+      (define (line)
+        (or (name-line)
+            (comment-line)
+            (org-line)
+            (instruction-line)))
+      (define (name-line)
+        (if (accept-token name-start-irx)
+            (cons 'name (string->symbol (accept-token name-irx #t)))
+            #f))
+      (define (comment-line)
+        (if (accept-token comment-irx)
+            '(comment)
+            #f))
+      (define (org-line)
+        (if (accept-token org-irx)
+            (cons 'org (string->number (accept-token number-irx #t)))
+            #f))
+      (define (instruction-line)
+        (let ((oc (opcode)))
+          (if oc
+              (let ((x (accept-token period-irx #t))
+                    (modif (modifier))
+                    (A-mode (mode))
+                    (A-num (accept-token number-irx #t))
+                    (y (accept-token comma-irx #t))
+                    (B-mode (mode))
+                    (B-num (accept-token number-irx #t))
+                    (z (accept-token comment-irx #t)))
+                (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
+              #f)))
+      (define (opcode)
+        (let ((res (or (accept-token opcode-DAT-irx)
+                       (accept-token opcode-MOV-irx)
+                       (accept-token opcode-ADD-irx)
+                       (accept-token opcode-SUB-irx)
+                       (accept-token opcode-MUL-irx)
+                       (accept-token opcode-DIV-irx)
+                       (accept-token opcode-MOD-irx)
+                       (accept-token opcode-JMP-irx)
+                       (accept-token opcode-JMZ-irx)
+                       (accept-token opcode-JMN-irx)
+                       (accept-token opcode-DJN-irx)
+                       (accept-token opcode-CMP-irx)
+                       (accept-token opcode-SEQ-irx)
+                       (accept-token opcode-SNE-irx)
+                       (accept-token opcode-SLT-irx)
+                       (accept-token opcode-SPL-irx)
+                       (accept-token opcode-NOP-irx))))
+          (if res (string->symbol res) #f)))
+      (define (modifier)
+        (string->symbol
+         (or (accept-token modifier-AB-irx)
+             (accept-token modifier-BA-irx)
+             (accept-token modifier-A-irx)
+             (accept-token modifier-B-irx)
+             (accept-token modifier-F-irx)
+             (accept-token modifier-X-irx)
+             (accept-token modifier-I-irx))))
+      (define (mode)
+        (or (mode-immediate)
+            (mode-direct)
+            (mode-indirect-A)
+            (mode-indirect-B)
+            (mode-pre-indirect-A)
+            (mode-pre-indirect-B)
+            (mode-post-indirect-A)
+            (mode-post-indirect-B)))
+      (define (mode-immediate)
+        (and (accept-token mode-immediate-irx)
+             'immediate))
+      (define (mode-direct)
+        (and (accept-token mode-direct-irx)
+             'direct))
+      (define (mode-indirect-A)
+        (and (accept-token mode-indirect-A-irx)
+             'indirect-A))
+      (define (mode-indirect-B)
+        (and (accept-token mode-indirect-B-irx)
+             'indirect-B))
+      (define (mode-pre-indirect-A)
+        (and (accept-token mode-pre-indirect-A-irx)
+             'pre-indirect-A))
+      (define (mode-pre-indirect-B)
+        (and (accept-token mode-pre-indirect-B-irx)
+             'pre-indirect-B))
+      (define (mode-post-indirect-A)
+        (and (accept-token mode-post-indirect-A-irx)
+             'post-indirect-A))
+      (define (mode-post-indirect-B)
+        (and (accept-token mode-post-indirect-B-irx)
+             'post-indirect-B))
+      (load-file))))

diff --git a/test.scm b/test.scm
index 090c941..7f6f921 100644 (file)
--- a/test.scm
+++ b/test.scm
@@ -1,27 +1,30 @@
-(import mars visualizer)
-
-(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 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")))
+(import 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 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 imp (string->prog (with-input-from-file "imp.red" read-string)))
+(define dwarf (string->prog (with-input-from-file "dwarf.red" read-string)))
+
+(define palette '((Imp . "red")
+                  (Dwarf . "blue")))
 
 (define vis (make-vis 640 480 8000 palette))
 
@@ -31,4 +34,4 @@
 
 (define queues (install-progs core (list dwarf imp)))
 
-;; (run-mars core queues 10000)
+(run-mars core queues 10000)