parser.scm

   1 (module parser
   2     (string->prog)
   3
   4   (import scheme
   5           (chicken base)
   6           (chicken irregex)
   7           (chicken io)
   8           (chicken string)
   9           srfi-13 mars)
  10
  11   (define (string->prog str)
  12     (let ((idx 0)
  13           (l (string-length str))
  14           (whitespace-irx (irregex "^[ \t]+"))
  15           (newline-irx (irregex "^\n"))
  16           (comma-irx (irregex "^,"))
  17           (period-irx (irregex "^\\."))
  18           (redcode-irx (irregex "^;redcode\n"))
  19           (name-start-irx (irregex "^;[ \t]*name "))
  20           (name-irx (irregex "^[a-zA-Z0-9]+"))
  21           (author-start-irx (irregex "^;[ \t]*author "))
  22           (author-irx (irregex "^[^\n]*"))
  23           (comment-irx (irregex "^(;[^\n]*)?\n"))
  24           (org-irx (irregex "^ORG"))
  25           (opcode-DAT-irx (irregex "^DAT"))
  26           (opcode-MOV-irx (irregex "^MOV"))
  27           (opcode-ADD-irx (irregex "^ADD"))
  28           (opcode-SUB-irx (irregex "^SUB"))
  29           (opcode-MUL-irx (irregex "^MUL"))
  30           (opcode-DIV-irx (irregex "^DIV"))
  31           (opcode-MOD-irx (irregex "^MOD"))
  32           (opcode-JMP-irx (irregex "^JMP"))
  33           (opcode-JMZ-irx (irregex "^JMZ"))
  34           (opcode-JMN-irx (irregex "^JMN"))
  35           (opcode-DMN-irx (irregex "^JMN"))
  36           (opcode-DJN-irx (irregex "^DJN"))
  37           (opcode-CMP-irx (irregex "^CMP"))
  38           (opcode-SEQ-irx (irregex "^SEQ"))
  39           (opcode-SNE-irx (irregex "^SNE"))
  40           (opcode-SLT-irx (irregex "^SLT"))
  41           (opcode-SPL-irx (irregex "^SPL"))
  42           (opcode-NOP-irx (irregex "^NOP"))
  43           (modifier-A-irx (irregex "^A"))
  44           (modifier-B-irx (irregex "^B"))
  45           (modifier-AB-irx (irregex "^AB"))
  46           (modifier-BA-irx (irregex "^BA"))
  47           (modifier-F-irx (irregex "^F"))
  48           (modifier-X-irx (irregex "^X"))
  49           (modifier-I-irx (irregex "^I"))
  50           (mode-immediate-irx (irregex "^#"))
  51           (mode-direct-irx (irregex "^\\$"))
  52           (mode-indirect-A-irx (irregex "^\\*"))
  53           (mode-indirect-B-irx (irregex "^@"))
  54           (mode-pre-indirect-A-irx (irregex "^\\{"))
  55           (mode-pre-indirect-B-irx (irregex "^<"))
  56           (mode-post-indirect-A-irx (irregex "^\\}"))
  57           (mode-post-indirect-B-irx (irregex "^>"))
  58           (number-irx (irregex "^(\\+|-)?[0-9]+")))
  59       (define (accept-token irx . rest)
  60         (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
  61           (if wsmatch
  62               (set! idx (+ idx (irregex-match-end-index wsmatch))))) ;Skip leading whitespace
  63         (let ((mandatory (and (= (length rest) 1) (car rest)))
  64               (res (irregex-search irx (substring str idx))))
  65           (if res
  66               (begin
  67                 (set! idx (+ idx (irregex-match-end-index res)))
  68                 (irregex-match-substring res))
  69               (if mandatory
  70                   (error "Unexpected token at input string index" idx)
  71                   #f))))
  72       (define (load-file)
  73         (accept-token redcode-irx #t)
  74         (let loop ((instrs '())
  75                    (offset 0)
  76                    (name '())
  77                    (author '()))
  78           (let ((this-line (line)))
  79             (if this-line
  80                 (case (car this-line)
  81                   ((name) (loop instrs offset (cdr this-line) author))
  82                   ((author) (loop instrs offset name (cdr this-line)))
  83                   ((comment) (loop instrs offset name author))
  84                   ((org) (loop instrs (cdr this-line) name author))
  85                   ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
  86                 (make-prog name author (reverse instrs) offset)))))
  87       (define (line)
  88         (or (name-line)
  89             (author-line)
  90             (comment-line)
  91             (org-line)
  92             (instruction-line)))
  93       (define (name-line)
  94         (if (accept-token name-start-irx)
  95             (cons 'name (string->symbol (accept-token name-irx #t)))
  96             #f))
  97       (define (author-line)
  98         (if (accept-token author-start-irx)
  99             (cons 'author (string-trim (accept-token author-irx #t)))
 100             #f))
 101       (define (comment-line)
 102         (if (accept-token comment-irx)
 103             '(comment)
 104             #f))
 105       (define (org-line)
 106         (if (accept-token org-irx)
 107             (cons 'org (string->number (accept-token number-irx #t)))
 108             #f))
 109       (define (instruction-line)
 110         (let ((oc (opcode)))
 111           (if oc
 112               (let ((x (accept-token period-irx #t))
 113                     (modif (modifier))
 114                     (A-mode (mode))
 115                     (A-num (string->number (accept-token number-irx #t)))
 116                     (y (accept-token comma-irx #t))
 117                     (B-mode (mode))
 118                     (B-num (string->number (accept-token number-irx #t)))
 119                     (z (accept-token comment-irx #t)))
 120                 (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
 121               #f)))
 122       (define (opcode)
 123         (let ((res (or (accept-token opcode-DAT-irx)
 124                        (accept-token opcode-MOV-irx)
 125                        (accept-token opcode-ADD-irx)
 126                        (accept-token opcode-SUB-irx)
 127                        (accept-token opcode-MUL-irx)
 128                        (accept-token opcode-DIV-irx)
 129                        (accept-token opcode-MOD-irx)
 130                        (accept-token opcode-JMP-irx)
 131                        (accept-token opcode-JMZ-irx)
 132                        (accept-token opcode-JMN-irx)
 133                        (accept-token opcode-DJN-irx)
 134                        (accept-token opcode-CMP-irx)
 135                        (accept-token opcode-SEQ-irx)
 136                        (accept-token opcode-SNE-irx)
 137                        (accept-token opcode-SLT-irx)
 138                        (accept-token opcode-SPL-irx)
 139                        (accept-token opcode-NOP-irx))))
 140           (if res (string->symbol res) #f)))
 141       (define (modifier)
 142         (string->symbol
 143          (or (accept-token modifier-AB-irx)
 144              (accept-token modifier-BA-irx)
 145              (accept-token modifier-A-irx)
 146              (accept-token modifier-B-irx)
 147              (accept-token modifier-F-irx)
 148              (accept-token modifier-X-irx)
 149              (accept-token modifier-I-irx))))
 150       (define (mode)
 151         (or (mode-immediate)
 152             (mode-direct)
 153             (mode-indirect-A)
 154             (mode-indirect-B)
 155             (mode-pre-indirect-A)
 156             (mode-pre-indirect-B)
 157             (mode-post-indirect-A)
 158             (mode-post-indirect-B)))
 159       (define (mode-immediate)
 160         (and (accept-token mode-immediate-irx)
 161              'immediate))
 162       (define (mode-direct)
 163         (and (accept-token mode-direct-irx)
 164              'direct))
 165       (define (mode-indirect-A)
 166         (and (accept-token mode-indirect-A-irx)
 167              'indirect-A))
 168       (define (mode-indirect-B)
 169         (and (accept-token mode-indirect-B-irx)
 170              'indirect-B))
 171       (define (mode-pre-indirect-A)
 172         (and (accept-token mode-pre-indirect-A-irx)
 173              'pre-indirect-A))
 174       (define (mode-pre-indirect-B)
 175         (and (accept-token mode-pre-indirect-B-irx)
 176              'pre-indirect-B))
 177       (define (mode-post-indirect-A)
 178         (and (accept-token mode-post-indirect-A-irx)
 179              'post-indirect-A))
 180       (define (mode-post-indirect-B)
 181         (and (accept-token mode-post-indirect-B-irx)
 182              'post-indirect-B))
 183       (load-file))))