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]+")))
59 (define (accept-token irx . rest)
60 (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
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))))
67 (set! idx (+ idx (irregex-match-end-index res)))
68 (irregex-match-substring res))
70 (error "Unexpected token at input string index" idx)
73 (accept-token redcode-irx #t)
74 (let loop ((instrs '())
78 (let ((this-line (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)))))
94 (if (accept-token name-start-irx)
95 (cons 'name (string-trim (accept-token name-irx #t)))
98 (if (accept-token author-start-irx)
99 (cons 'author (string-trim (accept-token author-irx #t)))
101 (define (comment-line)
102 (if (accept-token comment-irx)
106 (if (accept-token org-irx)
107 (cons 'org (string->number (accept-token number-irx #t)))
109 (define (instruction-line)
112 (let ((x (accept-token period-irx #t))
115 (A-num (string->number (accept-token number-irx #t)))
116 (y (accept-token comma-irx #t))
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)))
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)))
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))))
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)
162 (define (mode-direct)
163 (and (accept-token mode-direct-irx)
165 (define (mode-indirect-A)
166 (and (accept-token mode-indirect-A-irx)
168 (define (mode-indirect-B)
169 (and (accept-token mode-indirect-B-irx)
171 (define (mode-pre-indirect-A)
172 (and (accept-token mode-pre-indirect-A-irx)
174 (define (mode-pre-indirect-B)
175 (and (accept-token mode-pre-indirect-B-irx)
177 (define (mode-post-indirect-A)
178 (and (accept-token mode-post-indirect-A-irx)
180 (define (mode-post-indirect-B)
181 (and (accept-token mode-post-indirect-B-irx)