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