git @ Cat's Eye Technologies SixtyPical / cbeac87
Beginnings of using word tables Cat's Eye Technologies 7 years ago
6 changed file(s) with 115 addition(s) and 21 deletion(s). Raw diff Collapse all Expand all
167167 = .data
168168 = .space position 2
169169
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
170230 `main` is always emitted first.
171231
172232 | reserve word position
2525 reserve byte value
2626 reserve word compare_target
2727
28 reserve byte[16] actor_pos_hi
29 reserve byte[16] actor_pos_lo
28 reserve word[16] actor_pos
3029
3130 reserve vector dispatch_state
3231 reserve vector dispatch_logic
140139 ldy #0
141140 repeat bne {
142141 lda #$04
143 sta actor_pos_hi, y
142 // *** this is broken ***
143 sta >actor_pos, y
144144 tya
145145 clc
146146 asl .a
147147 asl .a
148 sta actor_pos_lo, y
148 sta <actor_pos, y
149149 iny
150150 cpy #8
151151 }
213213 repeat bne {
214214 stx save_x
215215
216 lda actor_pos_hi, x
217 sta >position
218 lda actor_pos_lo, x
219 sta <position
216 copy actor_pos, x position
220217
221218 cpx #0
222219 if beq {
227224 jsr indirect_jsr_logic
228225
229226 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
234229 inx
235230 cpx #8
236231 }
3030 where
3131 checkInstr j@(COPY _ (Indexed (NamedLocation sz g) reg)) =
3232 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
3535 Just _ -> (COPY A A)
3636 Nothing -> (COPY A A)
3737 checkInstr other = other
3939 showList [val] = show val
4040 showList (val:vals) = (show val) ++ ", " ++ (showList vals)
4141
42 emitDecl p (Reserve name (Table Word size) []) =
43 ".space " ++ name ++ "_lo " ++ (show size) ++ "\n" ++
44 ".space " ++ name ++ "_hi " ++ (show size)
45
4246 emitDecl p (Reserve name typ [])
4347 | typ == Byte = ".space " ++ name ++ " 1"
4448 | typ == Word = ".space " ++ name ++ " 2"
96100
97101 emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) X) A) = "lda " ++ label ++ ", x"
98102 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"
99125
100126 emitInstr p r (COPY A (IndirectIndexed (NamedLocation st label) Y)) = "sta (" ++ label ++ "), y"
101127 emitInstr p r (COPY (IndirectIndexed (NamedLocation st label) Y) A) = "lda (" ++ label ++ "), y"
574574 copy_general_statement = do
575575 string "copy"
576576 nspaces
577
577578 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
578585 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
584592
585593 copy_routine_statement :: Parser Instruction
586594 copy_routine_statement = do
111111 getType A = Byte
112112 getType X = Byte
113113 getType Y = Byte
114 getType (Immediate x) =
114 getType (Immediate x) = -- TODO! allow promotion!
115115 if x > 255 then Word else Byte
116 getType (Indexed t _) =
117 getType t
116118 getType _ = Byte
117119 typeMatch x y constructor =
118120 let
125127 (True, _, _) -> constructor rx ry
126128 (_, Byte, (Table Byte _)) -> constructor rx ry
127129 (_, (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))
129134 resolve (NamedLocation Nothing name) =
130135 case lookupDecl p name of
131136 Just decl ->