Initial, awkward support for block-level declarations, including a failing test.
Cat's Eye Technologies
8 years ago
89 | 89 | (Same should apply for `repeat` and `with` and, really, many other cases |
90 | 90 | which there just aren't enough test cases for yet.) |
91 | 91 | |
92 | Declarations can have block scope. Such declarations may only be used within | |
93 | the block in which they are declared. `reserve`d storage inside a block is not, | |
94 | however, like a local variable (or `auto` in C); rather, it is more like a | |
95 | `static` in C, except the value at that address is not guaranteed to be | |
96 | retained between invokations of the block. This is intended to be used for | |
97 | temporary storage. In addition, if analysis of the call graph indicates that | |
98 | two such temporary addresses are never used simultaneously, they may be merged | |
99 | to the same address. (This is, however, not yet implemented, and may not be | |
100 | implemented for a while.) | |
101 | ||
92 | 102 | ### "It's a Partial Solution" ### |
93 | 103 | |
94 | 104 | SixtyPical does not attempt to force your typed, abstractly interpreted |
120 | 130 | Falderal literate test suites. If you have Falderal installed, you can run |
121 | 131 | the tests with `./test.sh`.) |
122 | 132 | |
123 | Ideas | |
124 | ----- | |
125 | ||
126 | These aren't implemented yet: | |
127 | ||
128 | * Inside a routine, an address may be declared with `temporary`. This is like | |
129 | `static` in C, except the value at that address is not guaranteed to be | |
130 | retained between invokations of the routine. Such addresses may only be used | |
131 | within the routine where they are declared. If analysis indicates that two | |
132 | temporary addresses are never used simultaneously, they may be merged | |
133 | to the same address. | |
134 | ||
135 | 133 | Internals |
136 | 134 | --------- |
137 | 135 |
210 | 210 | = .space frequencies 16 |
211 | 211 | = .alias screen 1024 |
212 | 212 | |
213 | Temporary storage, in the form of block-local declarations. Note that these | |
214 | temporaries are not unioned yet, but they could be. | |
215 | ||
216 | | routine a { | |
217 | | reserve byte foo | |
218 | | reserve word bar | |
219 | | lda foo | |
220 | | sta >bar | |
221 | | } | |
222 | | routine b { | |
223 | | reserve byte baz | |
224 | | reserve word quuz | |
225 | | lda baz | |
226 | | sta <quuz | |
227 | | } | |
228 | | routine main { | |
229 | | jsr a | |
230 | | jsr b | |
231 | | } | |
232 | = main: | |
233 | = jsr a | |
234 | = jsr b | |
235 | = rts | |
236 | = a: | |
237 | = lda _temp_1 | |
238 | = sta _temp_2+1 | |
239 | = rts | |
240 | = b: | |
241 | = lda _temp_3 | |
242 | = sta _temp_4 | |
243 | = rts | |
244 | = | |
245 | = .data | |
246 | = .space _temp_1 1 | |
247 | = .space _temp_2 2 | |
248 | = .space _temp_3 1 | |
249 | = .space _temp_4 2⏎ |
22 | 22 | |
23 | 23 | checkRoutine (Routine name outputs instrs) progCtx routCtx = |
24 | 24 | checkBlock name instrs progCtx routCtx |
25 | ||
26 | checkBlock nm (Block decls instrs) progCtx routCtx = | |
27 | checkInstrs nm instrs progCtx routCtx | |
25 | 28 | |
26 | checkBlock nm [] progCtx routCtx = routCtx | |
27 | checkBlock nm (instr:instrs) progCtx routCtx = | |
29 | checkInstrs nm [] progCtx routCtx = routCtx | |
30 | checkInstrs nm (instr:instrs) progCtx routCtx = | |
28 | 31 | let |
29 | 32 | routCtx' = checkInstr nm instr progCtx routCtx |
30 | 33 | in |
31 | checkBlock nm instrs progCtx routCtx' | |
34 | checkInstrs nm instrs progCtx routCtx' | |
32 | 35 | |
33 | 36 | -- -- -- -- -- -- -- -- -- -- -- -- |
34 | 37 |
71 | 71 | ((routine':routines'), iid'') |
72 | 72 | |
73 | 73 | numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID) |
74 | numberRoutineLoops (Routine name outputs instrs) iid = | |
75 | let | |
76 | (instrs', iid') = numberBlockLoops instrs iid | |
77 | in | |
78 | ((Routine name outputs instrs'), iid') | |
79 | ||
80 | numberBlockLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID) | |
81 | numberBlockLoops [] iid = ([], iid) | |
82 | numberBlockLoops (instr:instrs) iid = | |
74 | numberRoutineLoops (Routine name outputs block) iid = | |
75 | let | |
76 | (block', iid') = numberBlockLoops block iid | |
77 | in | |
78 | ((Routine name outputs block'), iid') | |
79 | ||
80 | numberBlockLoops :: Block -> InternalID -> (Block, InternalID) | |
81 | numberBlockLoops block iid = | |
82 | let | |
83 | (Block decls instrs) = block | |
84 | (instrs', iid') = numberInstrsLoops instrs iid | |
85 | block' = Block decls instrs' | |
86 | in | |
87 | (block', iid') | |
88 | ||
89 | numberInstrsLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID) | |
90 | numberInstrsLoops [] iid = ([], iid) | |
91 | numberInstrsLoops (instr:instrs) iid = | |
83 | 92 | let |
84 | 93 | (instr', iid') = numberInstruction instr iid |
85 | (instrs', iid'') = numberBlockLoops instrs iid' | |
94 | (instrs', iid'') = numberInstrsLoops instrs iid' | |
86 | 95 | in |
87 | 96 | ((instr':instrs'), iid'') |
88 | 97 |
46 | 46 | emitRoutines p (rout:routs) = |
47 | 47 | emitRoutine p rout ++ "\n" ++ emitRoutines p routs |
48 | 48 | |
49 | emitRoutine p r@(Routine name _ instrs) = | |
50 | name ++ ":\n" ++ emitInstrs p r instrs ++ " rts\n" | |
49 | emitRoutine p r@(Routine name _ block) = | |
50 | name ++ ":\n" ++ emitBlock p r block ++ " rts\n" | |
51 | ||
52 | emitBlock p r (Block decls instrs) = | |
53 | emitInstrs p r instrs | |
51 | 54 | |
52 | 55 | emitInstrs _ _ [] = "" |
53 | 56 | emitInstrs p r (instr:instrs) = |
160 | 163 | |
161 | 164 | emitInstr p r (IF iid branch b1 b2) = |
162 | 165 | (show branch) ++ " _label_" ++ (show iid) ++ "\n" ++ |
163 | emitInstrs p r b2 ++ | |
166 | emitBlock p r b2 ++ | |
164 | 167 | " jmp _past_" ++ (show iid) ++ "\n" ++ |
165 | 168 | "_label_" ++ (show iid) ++ ":\n" ++ |
166 | emitInstrs p r b1 ++ | |
169 | emitBlock p r b1 ++ | |
167 | 170 | "_past_" ++ (show iid) ++ ":" |
168 | 171 | |
169 | 172 | emitInstr p r (REPEAT iid branch blk) = |
170 | 173 | "\n_repeat_" ++ (show iid) ++ ":\n" ++ |
171 | emitInstrs p r blk ++ | |
174 | emitBlock p r blk ++ | |
172 | 175 | " " ++ (show branch) ++ " _repeat_" ++ (show iid) |
173 | 176 | |
174 | 177 | emitInstr p r (WITH SEI blk) = |
175 | 178 | "sei\n" ++ |
176 | emitInstrs p r blk ++ | |
179 | emitBlock p r blk ++ | |
177 | 180 | " cli" |
178 | 181 | |
179 | 182 | emitInstr p r (WITH (PUSH A) blk) = |
180 | 183 | "pha\n" ++ |
181 | emitInstrs p r blk ++ | |
184 | emitBlock p r blk ++ | |
182 | 185 | " pla" |
183 | 186 | |
184 | 187 | emitInstr p r (WITH (PUSH AllFlags) blk) = |
185 | 188 | "php\n" ++ |
186 | emitInstrs p r blk ++ | |
189 | emitBlock p r blk ++ | |
187 | 190 | " plp" |
188 | 191 | |
189 | 192 | emitInstr p r (COPYROUTINE src (NamedLocation (Just Vector) dst)) = |
59 | 59 | | PUSH StorageLocation |
60 | 60 | deriving (Show, Ord, Eq) |
61 | 61 | |
62 | data Block = Block [Decl] [Instruction] | |
63 | deriving (Show, Ord, Eq) | |
64 | ||
62 | 65 | data Instruction = COPY StorageLocation StorageLocation |
63 | 66 | | CMP StorageLocation StorageLocation |
64 | 67 | | ADD StorageLocation StorageLocation |
72 | 75 | | JSR RoutineName |
73 | 76 | -- | JSRVECTOR StorageLocation |
74 | 77 | | JMPVECTOR StorageLocation |
75 | | IF InternalID Branch [Instruction] [Instruction] | |
76 | | REPEAT InternalID Branch [Instruction] | |
78 | | IF InternalID Branch Block Block | |
79 | | REPEAT InternalID Branch Block | |
77 | 80 | | DELTA StorageLocation DataValue |
78 | | WITH WithInstruction [Instruction] | |
81 | | WITH WithInstruction Block | |
79 | 82 | | COPYROUTINE RoutineName StorageLocation |
80 | 83 | | NOP |
81 | 84 | deriving (Show, Ord, Eq) |
82 | 85 | |
83 | data Routine = Routine RoutineName [StorageLocation] [Instruction] | |
86 | data Routine = Routine RoutineName [StorageLocation] Block | |
84 | 87 | deriving (Show, Ord, Eq) |
85 | 88 | |
86 | 89 | data Program = Program [Decl] [Routine] |
128 | 131 | |
129 | 132 | -- |
130 | 133 | |
131 | mapBlock :: (Instruction -> Instruction) -> [Instruction] -> [Instruction] | |
132 | mapBlock = map | |
134 | mapInstrs :: (Instruction -> Instruction) -> [Instruction] -> [Instruction] | |
135 | mapInstrs = map | |
136 | ||
137 | mapBlock :: (Instruction -> Instruction) -> Block -> Block | |
138 | mapBlock f (Block decls instrs) = | |
139 | Block decls (mapInstrs f instrs) | |
133 | 140 | |
134 | 141 | mapRoutine :: (Instruction -> Instruction) -> Routine -> Routine |
135 | mapRoutine f (Routine name outputs instrs) = | |
136 | Routine name outputs (mapBlock f instrs) | |
142 | mapRoutine f (Routine name outputs block) = | |
143 | Routine name outputs (mapBlock f block) | |
137 | 144 | |
138 | 145 | mapRoutines :: (Instruction -> Instruction) -> [Routine] -> [Routine] |
139 | 146 | mapRoutines f [] = [] |
146 | 153 | |
147 | 154 | -- |
148 | 155 | |
149 | foldBlock :: (Instruction -> a -> a) -> a -> [Instruction] -> a | |
150 | foldBlock = foldr | |
156 | foldInstrs :: (Instruction -> a -> a) -> a -> [Instruction] -> a | |
157 | foldInstrs = foldr | |
158 | ||
159 | foldBlock :: (Instruction -> a -> a) -> a -> Block -> a | |
160 | foldBlock f a (Block decls instrs) = | |
161 | foldInstrs f a instrs | |
151 | 162 | |
152 | 163 | foldRoutine :: (Instruction -> a -> a) -> a -> Routine -> a |
153 | 164 | foldRoutine f a (Routine name outputs instrs) = |
15 | 15 | | "external" RoutineName Address. |
16 | 16 | StorageType := "byte" ["[" Literal "]"] | "word" | "vector". |
17 | 17 | Routine := "routine" RoutineName ["outputs" "(" {LocationName} ")"] Block. |
18 | Block := "{" {Command} "}". | |
18 | Block := "{" {Decl} {Command} "}". | |
19 | 19 | Command := "if" Branch Block "else" Block |
20 | 20 | | "lda" (LocationName | Immediate) |
21 | 21 | | "ldx" (LocationName | Immediate) |
133 | 133 | |
134 | 134 | location = (try explicit_register <|> named_location) |
135 | 135 | |
136 | block :: Parser [Instruction] | |
136 | block :: Parser Block | |
137 | 137 | block = do |
138 | 138 | string "{" |
139 | 139 | nspaces |
140 | ds <- many decl | |
140 | 141 | cs <- many command |
141 | 142 | string "}" |
142 | 143 | nspaces |
143 | return cs | |
144 | return (Block ds cs) | |
144 | 145 | |
145 | 146 | -- -- -- -- -- -- commands -- -- -- -- -- |
146 | 147 |