11 (define (string->prog str)
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]+")))
60 (define (accept-token irx . rest)
61 (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
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))))
68 (set! idx (+ idx (irregex-match-end-index res)))
69 (irregex-match-substring res))
71 (error "Unexpected token at input string index" idx)
75 (accept-token redcode-irx #t)
76 (let loop ((instrs '())
80 (let ((this-line (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)))))
98 (if (accept-token name-start-irx)
99 (cons 'name (string-trim (accept-token name-irx #t)))
102 (define (author-line)
103 (if (accept-token author-start-irx)
104 (cons 'author (string-trim (accept-token author-irx #t)))
107 (define (comment-line)
108 (if (accept-token comment-irx)
113 (if (accept-token org-irx)
114 (cons 'org (string->number (accept-token number-irx #t)))
117 (define (instruction-line)
120 (let ((x (accept-token period-irx #t))
123 (A-num (string->number (accept-token number-irx #t)))
124 (y (accept-token comma-irx #t))
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)))
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)))
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))))
166 (mode-pre-indirect-A)
167 (mode-pre-indirect-B)
168 (mode-post-indirect-A)
169 (mode-post-indirect-B)))
171 (define (mode-immediate)
172 (and (accept-token mode-immediate-irx)
175 (define (mode-direct)
176 (and (accept-token mode-direct-irx)
179 (define (mode-indirect-A)
180 (and (accept-token mode-indirect-A-irx)
183 (define (mode-indirect-B)
184 (and (accept-token mode-indirect-B-irx)
187 (define (mode-pre-indirect-A)
188 (and (accept-token mode-pre-indirect-A-irx)
191 (define (mode-pre-indirect-B)
192 (and (accept-token mode-pre-indirect-B-irx)
195 (define (mode-post-indirect-A)
196 (and (accept-token mode-post-indirect-A-irx)
199 (define (mode-post-indirect-B)
200 (and (accept-token mode-post-indirect-B-irx)