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 "^[^\n]*"))
  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
  60       (define (accept-token irx . rest)
  61         (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
  62           (if wsmatch
  63               (set! idx (+ idx (irregex-match-end-index wsmatch))))) ;Skip leading whitespace
  64         (let ((mandatory (and (= (length rest) 1) (car rest)))
  65               (res (irregex-search irx (substring str idx))))
  66           (if res
  67               (begin
  68                 (set! idx (+ idx (irregex-match-end-index res)))
  69                 (irregex-match-substring res))
  70               (if mandatory
  71                   (error "Unexpected token at input string index" idx)
  72                   #f))))
  73
  74       (define (load-file)
  75         (accept-token redcode-irx #t)
  76         (let loop ((instrs '())
  77                    (offset 0)
  78                    (name '())
  79                    (author '()))
  80           (let ((this-line (line)))
  81             (if this-line
  82                 (case (car this-line)
  83                   ((name) (loop instrs offset (cdr this-line) author))
  84                   ((author) (loop instrs offset name (cdr this-line)))
  85                   ((comment) (loop instrs offset name author))
  86                   ((org) (loop instrs (cdr this-line) name author))
  87                   ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
  88                 (make-prog name author (reverse instrs) offset)))))
  89
  90       (define (line)
  91         (or (name-line)
  92             (author-line)
  93             (comment-line)
  94             (org-line)
  95             (instruction-line)))
  96
  97       (define (name-line)
  98         (if (accept-token name-start-irx)
  99             (cons 'name (string-trim (accept-token name-irx #t)))
 100             #f))
 101
 102       (define (author-line)
 103         (if (accept-token author-start-irx)
 104             (cons 'author (string-trim (accept-token author-irx #t)))
 105             #f))
 106
 107       (define (comment-line)
 108         (if (accept-token comment-irx)
 109             '(comment)
 110             #f))
 111
 112       (define (org-line)
 113         (if (accept-token org-irx)
 114             (cons 'org (string->number (accept-token number-irx #t)))
 115             #f))
 116
 117       (define (instruction-line)
 118         (let ((oc (opcode)))
 119           (if oc
 120               (let ((x (accept-token period-irx #t))
 121                     (modif (modifier))
 122                     (A-mode (mode))
 123                     (A-num (string->number (accept-token number-irx #t)))
 124                     (y (accept-token comma-irx #t))
 125                     (B-mode (mode))
 126                     (B-num (string->number (accept-token number-irx #t)))
 127                     (z (accept-token comment-irx #t)))
 128                 (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
 129               #f)))
 130
 131       (define (opcode)
 132         (let ((res (or (accept-token opcode-DAT-irx)
 133                        (accept-token opcode-MOV-irx)
 134                        (accept-token opcode-ADD-irx)
 135                        (accept-token opcode-SUB-irx)
 136                        (accept-token opcode-MUL-irx)
 137                        (accept-token opcode-DIV-irx)
 138                        (accept-token opcode-MOD-irx)
 139                        (accept-token opcode-JMP-irx)
 140                        (accept-token opcode-JMZ-irx)
 141                        (accept-token opcode-JMN-irx)
 142                        (accept-token opcode-DJN-irx)
 143                        (accept-token opcode-CMP-irx)
 144                        (accept-token opcode-SEQ-irx)
 145                        (accept-token opcode-SNE-irx)
 146                        (accept-token opcode-SLT-irx)
 147                        (accept-token opcode-SPL-irx)
 148                        (accept-token opcode-NOP-irx))))
 149           (if res (string->symbol res) #f)))
 150
 151       (define (modifier)
 152         (string->symbol
 153          (or (accept-token modifier-AB-irx)
 154              (accept-token modifier-BA-irx)
 155              (accept-token modifier-A-irx)
 156              (accept-token modifier-B-irx)
 157              (accept-token modifier-F-irx)
 158              (accept-token modifier-X-irx)
 159              (accept-token modifier-I-irx))))
 160
 161       (define (mode)
 162         (or (mode-immediate)
 163             (mode-direct)
 164             (mode-indirect-A)
 165             (mode-indirect-B)
 166             (mode-pre-indirect-A)
 167             (mode-pre-indirect-B)
 168             (mode-post-indirect-A)
 169             (mode-post-indirect-B)))
 170
 171       (define (mode-immediate)
 172         (and (accept-token mode-immediate-irx)
 173              'immediate))
 174
 175       (define (mode-direct)
 176         (and (accept-token mode-direct-irx)
 177              'direct))
 178
 179       (define (mode-indirect-A)
 180         (and (accept-token mode-indirect-A-irx)
 181              'indirect-A))
 182
 183       (define (mode-indirect-B)
 184         (and (accept-token mode-indirect-B-irx)
 185              'indirect-B))
 186
 187       (define (mode-pre-indirect-A)
 188         (and (accept-token mode-pre-indirect-A-irx)
 189              'pre-indirect-A))
 190
 191       (define (mode-pre-indirect-B)
 192         (and (accept-token mode-pre-indirect-B-irx)
 193              'pre-indirect-B))
 194
 195       (define (mode-post-indirect-A)
 196         (and (accept-token mode-post-indirect-A-irx)
 197              'post-indirect-A))
 198
 199       (define (mode-post-indirect-B)
 200         (and (accept-token mode-post-indirect-B-irx)
 201              'post-indirect-B))
 202
 203       (load-file))))