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

diff --git a/parser.scm b/parser.scm
index 11491b7..427d398 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)
@@ -18,6 +18,8 @@
           (redcode-irx (irregex "^;redcode\n"))
           (name-start-irx (irregex "^;[ \t]*name "))
           (name-irx (irregex "^[a-zA-Z0-9]+"))
+          (author-start-irx (irregex "^;[ \t]*author "))
+          (author-irx (irregex "^[^\n]*"))
           (comment-irx (irregex "^(;[^\n]*)?\n"))
           (org-irx (irregex "^ORG"))
           (opcode-DAT-irx (irregex "^DAT"))
@@ -71,17 +73,20 @@
         (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)))
@@ -89,6 +94,10 @@
         (if (accept-token name-start-irx)
             (cons 'name (string->symbol (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)
@@ -103,10 +112,10 @@
               (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)))