X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=parser.scm;h=c112cf9ccd9da9eda8b1d25ce9124374e6917260;hp=11491b7b65bd9bb5715a585d59cee5c009e32c14;hb=7281b0c1eefce213d11cada1cb9f86a2d8fb0779;hpb=6fa8a83fb4cf917fabe4c2bb930b8b092c9c7519

diff --git a/parser.scm b/parser.scm
index 11491b7..c112cf9 100644
--- a/parser.scm
+++ b/parser.scm
@@ -6,7 +6,7 @@
           (chicken irregex)
           (chicken io)
           (chicken string)
-          mars)
+          srfi-13 mars)
 
   (define (string->prog str)
     (let ((idx 0)
@@ -15,9 +15,11 @@
           (newline-irx (irregex "^\n"))
           (comma-irx (irregex "^,"))
           (period-irx (irregex "^\\."))
-          (redcode-irx (irregex "^;redcode\n"))
+          (redcode-irx (irregex "^;redcode.*\n"))
           (name-start-irx (irregex "^;[ \t]*name "))
-          (name-irx (irregex "^[a-zA-Z0-9]+"))
+          (name-irx (irregex "^[^\n]*"))
+          (author-start-irx (irregex "^;[ \t]*author "))
+          (author-irx (irregex "^[^\n]*"))
           (comment-irx (irregex "^(;[^\n]*)?\n"))
           (org-irx (irregex "^ORG"))
           (opcode-DAT-irx (irregex "^DAT"))
@@ -54,6 +56,7 @@
           (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
@@ -67,49 +70,64 @@
               (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 '()))
+                   (name '())
+                   (author '()))      
           (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)))))
+                  ((name) (loop instrs offset (cdr this-line) author))
+                  ((author) (loop instrs offset name (cdr this-line)))
+                  ((comment) (loop instrs offset name author))
+                  ((org) (loop instrs (cdr this-line) name author))
+                  ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
+                (make-prog name author (reverse instrs) offset)))))
+
       (define (line)
         (or (name-line)
+            (author-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)))
+            (cons 'name (string-trim (accept-token name-irx #t)))
+            #f))
+
+      (define (author-line)
+        (if (accept-token author-start-irx)
+            (cons 'author (string-trim (accept-token author-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))
+                    (A-num (string->number (accept-token number-irx #t)))
                     (y (accept-token comma-irx #t))
                     (B-mode (mode))
-                    (B-num (accept-token number-irx #t))
+                    (B-num (string->number (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)
@@ -129,6 +147,7 @@
                        (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)
@@ -138,6 +157,7 @@
              (accept-token modifier-F-irx)
              (accept-token modifier-X-irx)
              (accept-token modifier-I-irx))))
+
       (define (mode)
         (or (mode-immediate)
             (mode-direct)
@@ -147,28 +167,37 @@
             (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))))