git @ Cat's Eye Technologies SixtyPical / f3924d1
Lift block-level decls to top-level; still needs to rename them. --HG-- rename : src/SixtyPical/Checker.hs => src/SixtyPical/Transformer.hs Cat's Eye Technologies 8 years ago
2 changed file(s) with 195 addition(s) and 137 deletion(s). Raw diff Collapse all Expand all
+5
-137
src/SixtyPical/Checker.hs less more
22 module SixtyPical.Checker where
33
44 import SixtyPical.Model
5 import SixtyPical.Transformer
56
67 allTrue = foldl (&&) True
78
4950 False -> error ("undeclared routine '" ++ routName ++ "'") -- acc + 1
5051 checkInstr other acc = acc
5152
52 -- -- -- -- -- --
53
54 -- in the following "number" means "assign a unique ID to" and "loop"
55 -- means "REPEAT or IF" (because i'm in such a good mood)
56
57 numberProgramLoops :: Program -> Program
58 numberProgramLoops (Program decls routines) =
59 let
60 (routines', _) = numberRoutinesLoops routines 0
61 in
62 (Program decls routines')
63
64 numberRoutinesLoops :: [Routine] -> InternalID -> ([Routine], InternalID)
65 numberRoutinesLoops [] iid = ([], iid)
66 numberRoutinesLoops (routine:routines) iid =
67 let
68 (routine', iid') = numberRoutineLoops routine iid
69 (routines', iid'') = numberRoutinesLoops routines iid'
70 in
71 ((routine':routines'), iid'')
72
73 numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID)
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 =
92 let
93 (instr', iid') = numberInstruction instr iid
94 (instrs', iid'') = numberInstrsLoops instrs iid'
95 in
96 ((instr':instrs'), iid'')
97
98 numberInstruction :: Instruction -> InternalID -> (Instruction, InternalID)
99 numberInstruction (IF _ branch b1 b2) iid =
100 let
101 (b1', iid') = numberBlockLoops b1 iid
102 (b2', iid'') = numberBlockLoops b2 iid'
103 newIid = iid'' + 1
104 newInstr = IF newIid branch b1' b2'
105 in
106 (newInstr, newIid)
107 numberInstruction (REPEAT _ branch blk) iid =
108 let
109 (blk', iid') = numberBlockLoops blk iid
110 newIid = iid' + 1
111 newInstr = REPEAT newIid branch blk'
112 in
113 (newInstr, newIid)
114 numberInstruction i iid = (i, iid)
115
116 -- -- --
117
118 fillOutNamedLocationTypes p@(Program decls routines) =
119 mapProgramRoutines (xform) p
120 where
121 xform (COPY src dest) =
122 typeMatch src dest (COPY)
123 xform (CMP dest other) =
124 typeMatch dest other (CMP)
125 xform (ADD dest other) =
126 typeMatch dest other (ADD)
127 xform (AND dest other) =
128 typeMatch dest other (AND)
129 xform (SUB dest other) =
130 typeMatch dest other (SUB)
131 xform (OR dest other) =
132 typeMatch dest other (OR)
133 xform (JMPVECTOR dest) =
134 case (resolve dest) of
135 d@(NamedLocation (Just Vector) _) ->
136 JMPVECTOR d
137 _ ->
138 error ("jmp to non-vector '" ++ (show dest) ++ "'")
139 xform (IF iid branch b1 b2) =
140 IF iid branch (mapBlock xform b1) (mapBlock xform b2)
141 xform (REPEAT iid branch blk) =
142 REPEAT iid branch (mapBlock xform blk)
143 xform (DELTA dest val) =
144 DELTA (resolve dest) val
145 xform (WITH SEI blk) =
146 WITH SEI (mapBlock xform blk)
147 xform (WITH (PUSH val) blk) =
148 WITH (PUSH (resolve val)) (mapBlock xform blk)
149 xform (COPYROUTINE name dest) =
150 COPYROUTINE name (resolve dest)
151 xform other =
152 other
153 getType (NamedLocation (Just t) _) = t
154 getType A = Byte
155 getType X = Byte
156 getType Y = Byte
157 getType (Immediate x) =
158 if x > 255 then Word else Byte
159 getType _ = Byte
160 typeMatch x y constructor =
161 let
162 rx = resolve x
163 ry = resolve y
164 typeRx = getType rx
165 typeRy = getType ry
166 in
167 case (typeRx == typeRy, typeRx, typeRy) of
168 (True, _, _) -> constructor rx ry
169 (_, Byte, (ByteTable _)) -> constructor rx ry
170 (_, (ByteTable _), Byte) -> constructor rx ry
171 _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
172 resolve (NamedLocation Nothing name) =
173 case lookupDecl p name of
174 Just decl ->
175 (NamedLocation (Just $ getDeclLocationType decl) name)
176 _ ->
177 error ("undeclared location '" ++ name ++ "'")
178 resolve (Indirect loc) =
179 (Indirect (resolve loc))
180 resolve (Indexed loc reg) =
181 (Indexed (resolve loc) (resolve reg))
182 resolve (IndirectIndexed loc reg) =
183 (IndirectIndexed (resolve loc) (resolve reg))
184 resolve other =
185 other
186
18753 -- - - - - - -
18854
18955 checkAndTransformProgram :: Program -> Maybe Program
19763 then
19864 let
19965 program' = numberProgramLoops program
200 program'' = fillOutNamedLocationTypes program'
66 program'' = renameBlockDecls program'
67 program''' = liftBlockDecls program'
68 program'''' = fillOutNamedLocationTypes program'''
20169 in
202 Just program''
70 Just program''''
20371 else Nothing
+190
-0
src/SixtyPical/Transformer.hs less more
0 -- encoding: UTF-8
1
2 module SixtyPical.Transformer (
3 numberProgramLoops, fillOutNamedLocationTypes,
4 renameBlockDecls, liftBlockDecls
5 ) where
6
7 import SixtyPical.Model
8
9 -- -- -- -- -- --
10
11 -- in the following "number" means "assign a unique ID to" and "loop"
12 -- means "REPEAT or IF" (because i'm in such a good mood)
13
14 numberProgramLoops :: Program -> Program
15 numberProgramLoops (Program decls routines) =
16 let
17 (routines', _) = numberRoutinesLoops routines 0
18 in
19 (Program decls routines')
20
21 numberRoutinesLoops :: [Routine] -> InternalID -> ([Routine], InternalID)
22 numberRoutinesLoops [] iid = ([], iid)
23 numberRoutinesLoops (routine:routines) iid =
24 let
25 (routine', iid') = numberRoutineLoops routine iid
26 (routines', iid'') = numberRoutinesLoops routines iid'
27 in
28 ((routine':routines'), iid'')
29
30 numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID)
31 numberRoutineLoops (Routine name outputs block) iid =
32 let
33 (block', iid') = numberBlockLoops block iid
34 in
35 ((Routine name outputs block'), iid')
36
37 numberBlockLoops :: Block -> InternalID -> (Block, InternalID)
38 numberBlockLoops block iid =
39 let
40 (Block decls instrs) = block
41 (instrs', iid') = numberInstrsLoops instrs iid
42 block' = Block decls instrs'
43 in
44 (block', iid')
45
46 numberInstrsLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID)
47 numberInstrsLoops [] iid = ([], iid)
48 numberInstrsLoops (instr:instrs) iid =
49 let
50 (instr', iid') = numberInstruction instr iid
51 (instrs', iid'') = numberInstrsLoops instrs iid'
52 in
53 ((instr':instrs'), iid'')
54
55 numberInstruction :: Instruction -> InternalID -> (Instruction, InternalID)
56 numberInstruction (IF _ branch b1 b2) iid =
57 let
58 (b1', iid') = numberBlockLoops b1 iid
59 (b2', iid'') = numberBlockLoops b2 iid'
60 newIid = iid'' + 1
61 newInstr = IF newIid branch b1' b2'
62 in
63 (newInstr, newIid)
64 numberInstruction (REPEAT _ branch blk) iid =
65 let
66 (blk', iid') = numberBlockLoops blk iid
67 newIid = iid' + 1
68 newInstr = REPEAT newIid branch blk'
69 in
70 (newInstr, newIid)
71 numberInstruction i iid = (i, iid)
72
73 -- -- --
74
75 fillOutNamedLocationTypes p@(Program decls routines) =
76 mapProgramRoutines (xform) p
77 where
78 xform (COPY src dest) =
79 typeMatch src dest (COPY)
80 xform (CMP dest other) =
81 typeMatch dest other (CMP)
82 xform (ADD dest other) =
83 typeMatch dest other (ADD)
84 xform (AND dest other) =
85 typeMatch dest other (AND)
86 xform (SUB dest other) =
87 typeMatch dest other (SUB)
88 xform (OR dest other) =
89 typeMatch dest other (OR)
90 xform (JMPVECTOR dest) =
91 case (resolve dest) of
92 d@(NamedLocation (Just Vector) _) ->
93 JMPVECTOR d
94 _ ->
95 error ("jmp to non-vector '" ++ (show dest) ++ "'")
96 xform (IF iid branch b1 b2) =
97 IF iid branch (mapBlock xform b1) (mapBlock xform b2)
98 xform (REPEAT iid branch blk) =
99 REPEAT iid branch (mapBlock xform blk)
100 xform (DELTA dest val) =
101 DELTA (resolve dest) val
102 xform (WITH SEI blk) =
103 WITH SEI (mapBlock xform blk)
104 xform (WITH (PUSH val) blk) =
105 WITH (PUSH (resolve val)) (mapBlock xform blk)
106 xform (COPYROUTINE name dest) =
107 COPYROUTINE name (resolve dest)
108 xform other =
109 other
110 getType (NamedLocation (Just t) _) = t
111 getType A = Byte
112 getType X = Byte
113 getType Y = Byte
114 getType (Immediate x) =
115 if x > 255 then Word else Byte
116 getType _ = Byte
117 typeMatch x y constructor =
118 let
119 rx = resolve x
120 ry = resolve y
121 typeRx = getType rx
122 typeRy = getType ry
123 in
124 case (typeRx == typeRy, typeRx, typeRy) of
125 (True, _, _) -> constructor rx ry
126 (_, Byte, (ByteTable _)) -> constructor rx ry
127 (_, (ByteTable _), Byte) -> constructor rx ry
128 _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
129 resolve (NamedLocation Nothing name) =
130 case lookupDecl p name of
131 Just decl ->
132 (NamedLocation (Just $ getDeclLocationType decl) name)
133 _ ->
134 error ("undeclared location '" ++ name ++ "'")
135 resolve (Indirect loc) =
136 (Indirect (resolve loc))
137 resolve (Indexed loc reg) =
138 (Indexed (resolve loc) (resolve reg))
139 resolve (IndirectIndexed loc reg) =
140 (IndirectIndexed (resolve loc) (resolve reg))
141 resolve other =
142 other
143
144 -- -- -- -- --
145
146 -- TODO: look at all blocks, not just routine's blocks
147 renameBlockDecls (Program decls routines) =
148 let
149 routines' = map renameRoutineDecls routines
150 in
151 Program decls routines'
152 where
153 renameRoutineDecls (Routine name outputs block) =
154 let
155 (Block decls _) = block
156 block' = foldDeclsRenaming decls block
157 in
158 (Routine name outputs block')
159
160 -- TODO will have to return new decls too
161 -- TODO will have to take accumulator too
162 -- TODO accumulator has to range across all routines too!
163 foldDeclsRenaming [] block = block
164 foldDeclsRenaming ((Reserve name typ Nothing):decls) block =
165 let
166 newName = "_temp_1" -- TODO base this on accumulator
167 block' = mapBlockNames name newName block
168 in
169 foldDeclsRenaming decls block'
170
171 mapBlockNames n1 n2 (Block decls instrs) =
172 (Block decls $ mapInstrsNames n1 n2 instrs)
173
174 -- TODO: write this
175 mapInstrsNames n1 n2 instrs = instrs
176
177 -- -- -- --
178
179 -- TODO: look at all blocks, not just routine's blocks
180 liftBlockDecls (Program decls routines) =
181 let
182 liftedDecls = foldr getRoutinesBlockDecls [] routines
183 in
184 Program (decls ++ liftedDecls) routines
185 where
186 getRoutinesBlockDecls (Routine name outputs block) a =
187 a ++ (getBlockDecls block)
188 getBlockDecls (Block decls instrs) =
189 decls