Beginnings of using word tables
Cat's Eye Technologies
8 years ago
167 | 167 | = .data |
168 | 168 | = .space position 2 |
169 | 169 | |
170 | Copy command: word -> word | |
171 | ||
172 | | reserve word position1 | |
173 | | reserve word position2 | |
174 | | routine main { | |
175 | | copy position1 position2 | |
176 | | } | |
177 | = main: | |
178 | = lda position1 | |
179 | = sta position2 | |
180 | = lda position1+1 | |
181 | = sta position2+1 | |
182 | = rts | |
183 | = | |
184 | = .data | |
185 | = .space position1 2 | |
186 | = .space position2 2 | |
187 | ||
188 | Copy command: word -> word indexed | |
189 | ||
190 | | reserve word loc | |
191 | | reserve word[4] locs | |
192 | | routine main { | |
193 | | ldy #0 | |
194 | | copy loc locs, y | |
195 | | } | |
196 | = main: | |
197 | = ldy #0 | |
198 | = lda loc | |
199 | = sta locs_lo, y | |
200 | = lda loc+1 | |
201 | = sta locs_hi, y | |
202 | = rts | |
203 | = | |
204 | = .data | |
205 | = .space loc 2 | |
206 | = .space locs_lo 4 | |
207 | = .space locs_hi 4 | |
208 | ||
209 | Copy command: word INDEXED -> word | |
210 | ||
211 | | reserve word loc | |
212 | | reserve word[4] locs | |
213 | | routine main { | |
214 | | ldx #0 | |
215 | | copy locs, x loc | |
216 | | } | |
217 | = main: | |
218 | = ldx #0 | |
219 | = lda locs_lo, x | |
220 | = sta loc | |
221 | = lda locs_hi, x | |
222 | = sta loc+1 | |
223 | = rts | |
224 | = | |
225 | = .data | |
226 | = .space loc 2 | |
227 | = .space locs_lo 4 | |
228 | = .space locs_hi 4 | |
229 | ||
170 | 230 | `main` is always emitted first. |
171 | 231 | |
172 | 232 | | reserve word position |
25 | 25 | reserve byte value |
26 | 26 | reserve word compare_target |
27 | 27 | |
28 | reserve byte[16] actor_pos_hi | |
29 | reserve byte[16] actor_pos_lo | |
28 | reserve word[16] actor_pos | |
30 | 29 | |
31 | 30 | reserve vector dispatch_state |
32 | 31 | reserve vector dispatch_logic |
140 | 139 | ldy #0 |
141 | 140 | repeat bne { |
142 | 141 | lda #$04 |
143 | sta actor_pos_hi, y | |
142 | // *** this is broken *** | |
143 | sta >actor_pos, y | |
144 | 144 | tya |
145 | 145 | clc |
146 | 146 | asl .a |
147 | 147 | asl .a |
148 | sta actor_pos_lo, y | |
148 | sta <actor_pos, y | |
149 | 149 | iny |
150 | 150 | cpy #8 |
151 | 151 | } |
213 | 213 | repeat bne { |
214 | 214 | stx save_x |
215 | 215 | |
216 | lda actor_pos_hi, x | |
217 | sta >position | |
218 | lda actor_pos_lo, x | |
219 | sta <position | |
216 | copy actor_pos, x position | |
220 | 217 | |
221 | 218 | cpx #0 |
222 | 219 | if beq { |
227 | 224 | jsr indirect_jsr_logic |
228 | 225 | |
229 | 226 | ldx save_x |
230 | lda >position | |
231 | sta actor_pos_hi, x | |
232 | lda <position | |
233 | sta actor_pos_lo, x | |
227 | copy position actor_pos, x | |
228 | ||
234 | 229 | inx |
235 | 230 | cpx #8 |
236 | 231 | } |
30 | 30 | where |
31 | 31 | checkInstr j@(COPY _ (Indexed (NamedLocation sz g) reg)) = |
32 | 32 | case lookupDecl p g of |
33 | Just (Assign _ (Table Byte _) _) -> j | |
34 | Just (Reserve _ (Table Byte _) _) -> j | |
33 | Just (Assign _ (Table _ _) _) -> j | |
34 | Just (Reserve _ (Table _ _) _) -> j | |
35 | 35 | Just _ -> (COPY A A) |
36 | 36 | Nothing -> (COPY A A) |
37 | 37 | checkInstr other = other |
39 | 39 | showList [val] = show val |
40 | 40 | showList (val:vals) = (show val) ++ ", " ++ (showList vals) |
41 | 41 | |
42 | emitDecl p (Reserve name (Table Word size) []) = | |
43 | ".space " ++ name ++ "_lo " ++ (show size) ++ "\n" ++ | |
44 | ".space " ++ name ++ "_hi " ++ (show size) | |
45 | ||
42 | 46 | emitDecl p (Reserve name typ []) |
43 | 47 | | typ == Byte = ".space " ++ name ++ " 1" |
44 | 48 | | typ == Word = ".space " ++ name ++ " 2" |
96 | 100 | |
97 | 101 | emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) X) A) = "lda " ++ label ++ ", x" |
98 | 102 | emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) Y) A) = "lda " ++ label ++ ", y" |
103 | ||
104 | emitInstr p r (COPY (NamedLocation (Just st1) src) (Indexed (NamedLocation (Just (Table st2 _)) dst) reg)) | |
105 | | (st1 == Vector && st2 == Vector) || (st1 == Word && st2 == Word) = | |
106 | "lda " ++ src ++ "\n" ++ | |
107 | " sta " ++ dst ++ "_lo, " ++ r ++ "\n" ++ | |
108 | " lda " ++ src ++ "+1\n" ++ | |
109 | " sta " ++ dst ++ "_hi, " ++ r | |
110 | where | |
111 | r = case reg of | |
112 | X -> "x" | |
113 | Y -> "y" | |
114 | ||
115 | emitInstr p r (COPY (Indexed (NamedLocation (Just (Table st1 _)) src) reg) (NamedLocation (Just st2) dst)) | |
116 | | (st1 == Vector && st2 == Vector) || (st1 == Word && st2 == Word) = | |
117 | "lda " ++ src ++ "_lo, " ++ r ++ "\n" ++ | |
118 | " sta " ++ dst ++ "\n" ++ | |
119 | " lda " ++ src ++ "_hi, " ++ r ++ "\n" ++ | |
120 | " sta " ++ dst ++ "+1" | |
121 | where | |
122 | r = case reg of | |
123 | X -> "x" | |
124 | Y -> "y" | |
99 | 125 | |
100 | 126 | emitInstr p r (COPY A (IndirectIndexed (NamedLocation st label) Y)) = "sta (" ++ label ++ "), y" |
101 | 127 | emitInstr p r (COPY (IndirectIndexed (NamedLocation st label) Y) A) = "lda (" ++ label ++ "), y" |
574 | 574 | copy_general_statement = do |
575 | 575 | string "copy" |
576 | 576 | nspaces |
577 | ||
577 | 578 | src <- (try immediate <|> try direct_location) |
579 | srcI <- many index | |
580 | lhs <- return $ case (src, srcI) of | |
581 | ((Immediately s), []) -> (Immediate s) | |
582 | ((Directly s), []) -> (NamedLocation Nothing s) | |
583 | ((Directly s), [reg]) -> (Indexed (NamedLocation Nothing s) reg) | |
584 | ||
578 | 585 | dst <- direct_location |
579 | return $ case (src, dst) of | |
580 | (Immediately s, Directly d) -> | |
581 | (COPY (Immediate s) (NamedLocation Nothing d)) | |
582 | (Directly s, Directly d) -> | |
583 | (COPY (NamedLocation Nothing s) (NamedLocation Nothing d)) | |
586 | dstI <- many index | |
587 | rhs <- return $ case (dst, dstI) of | |
588 | ((Directly d), []) -> (NamedLocation Nothing d) | |
589 | ((Directly d), [reg]) -> (Indexed (NamedLocation Nothing d) reg) | |
590 | ||
591 | return $ COPY lhs rhs | |
584 | 592 | |
585 | 593 | copy_routine_statement :: Parser Instruction |
586 | 594 | copy_routine_statement = do |
111 | 111 | getType A = Byte |
112 | 112 | getType X = Byte |
113 | 113 | getType Y = Byte |
114 | getType (Immediate x) = | |
114 | getType (Immediate x) = -- TODO! allow promotion! | |
115 | 115 | if x > 255 then Word else Byte |
116 | getType (Indexed t _) = | |
117 | getType t | |
116 | 118 | getType _ = Byte |
117 | 119 | typeMatch x y constructor = |
118 | 120 | let |
125 | 127 | (True, _, _) -> constructor rx ry |
126 | 128 | (_, Byte, (Table Byte _)) -> constructor rx ry |
127 | 129 | (_, (Table Byte _), Byte) -> constructor rx ry |
128 | _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'") | |
130 | (_, Word, (Table Word _)) -> constructor rx ry | |
131 | (_, (Table Word _), Word) -> constructor rx ry | |
132 | _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'" ++ | |
133 | " " ++ (show rx) ++ "," ++ (show ry)) | |
129 | 134 | resolve (NamedLocation Nothing name) = |
130 | 135 | case lookupDecl p name of |
131 | 136 | Just decl -> |