source: Deliverables/D4.1/ASMInterpret.ml @ 121

Last change on this file since 121 was 121, checked in by mulligan, 9 years ago

Fixed obscure type error in pretty.

File size: 48.2 KB
Line 
1open BitVectors;;
2open Physical;;
3open ASM;;
4open Pretty;;
5
6exception Fetch_exception of string;;
7exception CodeTooLarge;;
8exception Halt;;
9
10type time = int;;
11
12(* no differentiation between internal and external code memory *)
13type status =
14 { code_memory: WordMap.map;        (* can be reduced *)
15   low_internal_ram: Byte7Map.map;
16   high_internal_ram: Byte7Map.map;
17   external_ram: WordMap.map;
18
19   pc: word;
20
21   (* sfr *)
22   p0: byte;
23   sp: byte;
24   dpl: byte;
25   dph: byte;
26   pcon: byte;
27   tcon: byte;
28   tmod: byte;
29   tl0: byte;
30   tl1: byte;
31   th0: byte;
32   th1: byte;
33   p1: byte;
34   scon: byte;
35   sbuf: byte;
36   p2: byte;
37   ie: byte;
38   p3: byte;
39   ip: byte;
40   psw: byte;
41   acc: byte;
42   b: byte;
43
44   clock: time;
45   timer0: word;
46   timer1: word;
47   timer2: word;  (* can be missing *)
48   io: time * int -> byte option
49 }
50
51let initialize = {
52  code_memory = WordMap.empty;
53  low_internal_ram = Byte7Map.empty;
54  high_internal_ram = Byte7Map.empty;
55  external_ram = WordMap.empty;
56
57  pc = zero `Sixteen;
58
59  p0 = zero `Eight;
60  sp = vect_of_int 7 `Eight;
61  dpl = zero `Eight;
62  dph = zero `Eight;
63  pcon = zero `Eight;
64  tcon = zero `Eight;
65  tmod = zero `Eight;
66  tl0 = zero `Eight;
67  tl1 = zero `Eight;
68  th0 = zero `Eight;
69  th1 = zero `Eight;
70  p1 = zero `Eight;
71  scon = zero `Eight;
72  sbuf = zero `Eight;
73  p2 = zero `Eight;
74  ie = zero `Eight;
75  p3 = zero `Eight;
76  ip = zero `Eight;
77  psw = zero `Eight;
78  acc = zero `Eight;
79  b = zero `Eight;
80  clock = 0;
81  timer0 = zero `Sixteen;
82  timer1 = zero `Sixteen;
83  timer2 = zero `Sixteen;
84
85  io = (fun (time, line) -> None)
86}
87
88let get_cy_flag status =
89  let (cy,_,_,_),(_,_,_,_) = bits_of_byte status.psw in cy
90let get_ac_flag status =
91  let (_,ac,_,_),(_,_,_,_) = bits_of_byte status.psw in ac
92let get_fo_flag status =
93  let (_,_,fo,_),(_,_,_,_) = bits_of_byte status.psw in fo
94let get_rs1_flag status =
95  let (_,_,_,rs1),(_,_,_,_) = bits_of_byte status.psw in rs1
96let get_rs0_flag status =
97  let (_,_,_,_),(rs0,_,_,_) = bits_of_byte status.psw in rs0
98let get_ov_flag status =
99  let (_,_,_,_),(_,ov,_,_) = bits_of_byte status.psw in ov
100let get_ud_flag status =
101  let (_,_,_,_),(_,_,ud,_) = bits_of_byte status.psw in ud
102let get_p_flag status =
103  let (_,_,_,_),(_,_,_,p) = bits_of_byte status.psw in p
104
105(* timings taken from SIEMENS *)
106
107let fetch pmem pc =
108 let next pc =
109   let (carry, res) = half_add pc (vect_of_int 1 `Sixteen) in
110     res, WordMap.find pc pmem
111 in
112 let instr = WordMap.find pc pmem in
113 let cy, pc = half_add pc (vect_of_int 1 `Sixteen) in
114 let (un, ln) = from_byte instr in
115 let bits = (from_nibble un, from_nibble ln) in
116  match bits with
117     (a10,a9,a8,true),(false,false,false,true) ->
118      let pc,b1 = next pc in
119       `ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
120   | (false,false,true,false),(true,r1,r2,r3) ->
121       `ADD (`A,`REG (r1,r2,r3)), pc, 1
122   | (false,false,true,false),(false,true,false,true) ->
123      let pc,b1 = next pc in
124       `ADD (`A,`DIRECT b1), pc, 1
125   | (false,false,true,false),(false,true,true,i1) ->
126       `ADD (`A,`INDIRECT i1), pc, 1
127   | (false,false,true,false),(false,true,false,false) ->
128      let pc,b1 = next pc in
129       `ADD (`A,`DATA b1), pc, 1
130   | (false,false,true,true),(true,r1,r2,r3) ->
131       `ADDC (`A,`REG (r1,r2,r3)), pc, 1
132   | (false,false,true,true),(false,true,false,true) ->
133      let pc,b1 = next pc in
134       `ADDC (`A,`DIRECT b1), pc, 1
135   | (false,false,true,true),(false,true,true,i1) ->
136       `ADDC (`A,`INDIRECT i1), pc, 1
137   | (false,false,true,true),(false,true,false,false) ->
138      let pc,b1 = next pc in
139       `ADDC (`A,`DATA b1), pc, 1
140   | (a10,a9,a8,false),(false,false,false,true) ->
141      let pc,b1 = next pc in
142       `AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
143   | (false,true,false,true),(true,r1,r2,r3) ->
144       `ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1
145   | (false,true,false,true),(false,true,false,true) ->
146      let pc,b1 = next pc in
147       `ANL (`U1 (`A, `DIRECT b1)), pc, 1
148   | (false,true,false,true),(false,true,true,i1) ->
149       `ANL (`U1 (`A, `INDIRECT i1)), pc, 1
150   | (false,true,false,true),(false,true,false,false) ->
151      let pc,b1 = next pc in
152       `ANL (`U1 (`A, `DATA b1)), pc, 1
153   | (false,true,false,true),(false,false,true,false) ->
154      let pc,b1 = next pc in
155       `ANL (`U2 (`DIRECT b1,`A)), pc, 1
156   | (false,true,false,true),(false,false,true,true) ->
157      let pc,b1 = next pc in
158      let pc,b2 = next pc in
159       `ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2
160   | (true,false,false,false),(false,false,true,false) ->
161      let pc,b1 = next pc in
162       `ANL (`U3 (`C,`BIT b1)), pc, 2
163   | (true,false,true,true),(false,false,false,false) ->
164      let pc,b1 = next pc in
165       `ANL (`U3 (`C,`NBIT b1)), pc, 2
166   | (true,false,true,true),(false,true,false,true) ->
167      let       pc,b1 = next pc in
168      let pc,b2 = next pc in
169        `CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2
170   | (true,false,true,true),(false,true,false,false) ->
171       let pc,b1 = next pc in
172       let pc,b2 = next pc in
173         `CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2
174   | (true,false,true,true),(true,r1,r2,r3) ->
175       let pc,b1 = next pc in
176       let pc,b2 = next pc in
177         `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2
178   | (true,false,true,true),(false,true,true,i1) ->
179       let pc,b1 = next pc in
180       let pc,b2 = next pc in
181         `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2
182   | (true,true,true,false),(false,true,false,false) ->
183         `CLR `A, pc, 1
184   | (true,true,false,false),(false,false,true,true) ->
185         `CLR `C, pc, 1
186   | (true,true,false,false),(false,false,true,false) ->
187       let pc,b1 = next pc in
188         `CLR (`BIT b1), pc, 1
189   | (true,true,true,true),(false,true,false,false) ->
190         `CPL `A, pc, 1
191   | (true,false,true,true),(false,false,true,true) ->
192         `CPL `C, pc, 1
193   | (true,false,true,true),(false,false,true,false) ->
194       let pc,b1 = next pc in
195         `CPL (`BIT b1), pc, 1
196   | (true,true,false,true),(false,true,false,false) ->
197         `DA `A, pc, 1
198   | (false,false,false,true),(false,true,false,false) ->
199         `DEC `A, pc, 1
200   | (false,false,false,true),(true,r1,r2,r3) ->
201         `DEC (`REG(r1,r2,r3)), pc, 1
202   | (false,false,false,true),(false,true,false,true) ->
203       let pc,b1 = next pc in
204         `DEC (`DIRECT b1), pc, 1
205   | (false,false,false,true),(false,true,true,i1) ->
206         `DEC (`INDIRECT i1), pc, 1
207   | (true,false,false,false),(false,true,false,false) ->
208         `DIV (`A, `B), pc, 4
209   | (true,true,false,true),(true,r1,r2,r3) ->
210       let pc,b1 = next pc in
211         `DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2
212   | (true,true,false,true),(false,true,false,true) ->
213       let pc,b1 = next pc in
214       let pc,b2 = next pc in
215         `DJNZ (`DIRECT b1, `REL b2), pc, 2
216   | (false,false,false,false),(false,true,false,false) ->
217         `INC `A, pc, 1
218   | (false,false,false,false),(true,r1,r2,r3) ->
219         `INC (`REG(r1,r2,r3)), pc, 1
220   | (false,false,false,false),(false,true,false,true) ->
221       let pc,b1 = next pc in
222         `INC (`DIRECT b1), pc, 1
223   | (false,false,false,false),(false,true,true,i1) ->
224         `INC (`INDIRECT i1), pc, 1
225   | (true,false,true,false),(false,false,true,true) ->
226         `INC `DPTR, pc, 2
227   | (false,false,true,false),(false,false,false,false) ->
228       let pc,b1 = next pc in
229       let pc,b2 = next pc in
230         `JB (`BIT b1, `REL b2), pc, 2
231   | (false,false,false,true),(false,false,false,false) ->
232       let pc,b1 = next pc in
233       let pc,b2 = next pc in
234         `JBC (`BIT b1, `REL b2), pc, 2
235   | (false,true,false,false),(false,false,false,false) ->
236       let pc,b1 = next pc in
237         `JC (`REL b1), pc, 2
238   | (false,true,true,true),(false,false,true,true) ->
239         `JMP `IND_DPTR, pc, 2
240   | (false,false,true,true),(false,false,false,false) ->
241       let pc,b1 = next pc in
242       let pc,b2 = next pc in
243         `JNB (`BIT b1, `REL b2), pc, 2
244   | (false,true,false,true),(false,false,false,false) ->
245       let pc,b1 = next pc in
246         `JNC (`REL b1), pc, 2
247   | (false,true,true,true),(false,false,false,false) ->
248       let pc,b1 = next pc in
249         `JNZ (`REL b1), pc, 2
250   | (false,true,true,false),(false,false,false,false) ->
251       let pc,b1 = next pc in
252         `JZ (`REL b1), pc, 2
253   | (false,false,false,true),(false,false,true,false) ->
254       let pc,b1 = next pc in
255       let pc,b2 = next pc in
256         `LCALL (`ADDR16 (mk_word b1 b2)), pc, 2
257   | (false,false,false,false),(false,false,true,false) ->
258       let pc,b1 = next pc in
259       let pc,b2 = next pc in
260         `LJMP (`ADDR16 (mk_word b1 b2)), pc, 2
261   | (true,true,true,false),(true,r1,r2,r3) ->
262         `MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1
263   | (true,true,true,false),(false,true,false,true) ->
264       let pc,b1 = next pc in
265         `MOV (`U1 (`A, `DIRECT b1)), pc, 1
266   | (true,true,true,false),(false,true,true,i1) ->
267         `MOV (`U1 (`A, `INDIRECT i1)), pc, 1
268   | (false,true,true,true),(false,true,false,false) ->
269       let pc,b1 = next pc in
270         `MOV (`U1 (`A, `DATA b1)), pc, 1
271   | (true,true,true,true),(true,r1,r2,r3) ->
272         `MOV (`U2 (`REG(r1,r2,r3), `A)), pc, 1
273   | (true,false,true,false),(true,r1,r2,r3) ->
274       let pc,b1 = next pc in
275         `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))), pc, 2
276   | (false,true,true,true),(true,r1,r2,r3) ->
277       let pc,b1 = next pc in
278         `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))), pc, 1
279   | (true,true,true,true),(false,true,false,true) ->
280       let pc,b1 = next pc in
281         `MOV (`U3 (`DIRECT b1, `A)), pc, 1
282   | (true,false,false,false),(true,r1,r2,r3) ->
283       let pc,b1 = next pc in
284         `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))), pc, 2
285   | (true,false,false,false),(false,true,false,true) ->
286       let pc,b1 = next pc in
287       let pc,b2 = next pc in
288         `MOV (`U3 (`DIRECT b1, `DIRECT b2)), pc, 2
289   | (true,false,false,false),(false,true,true,i1) ->
290       let pc,b1 = next pc in
291         `MOV (`U3 (`DIRECT b1, `INDIRECT i1)), pc, 2
292   | (false,true,true,true),(false,true,false,true) ->
293       let pc,b1 = next pc in
294       let pc,b2 = next pc in
295         `MOV (`U3 (`DIRECT b1, `DATA b2)), pc, 2
296   | (true,true,true,true),(false,true,true,i1) ->
297         `MOV (`U2 (`INDIRECT i1, `A)), pc, 1
298   | (true,false,true,false),(false,true,true,i1) ->
299       let pc,b1 = next pc in
300         `MOV (`U2 (`INDIRECT i1, `DIRECT b1)), pc, 2
301   | (false,true,true,true),(false,true,true,i1) ->
302       let pc,b1 = next pc in
303         `MOV (`U2 (`INDIRECT i1, `DATA b1)), pc, 1
304   | (true,false,true,false),(false,false,true,false) ->
305       let pc,b1 = next pc in
306         `MOV (`U5 (`C, `BIT b1)), pc, 1
307   | (true,false,false,true),(false,false,true,false) ->
308       let pc,b1 = next pc in
309         `MOV (`U6 (`BIT b1, `C)), pc, 2
310   | (true,false,false,true),(false,false,false,false) ->
311       let pc,b1 = next pc in
312       let pc,b2 = next pc in
313         `MOV (`U4 (`DPTR, `DATA16(mk_word b1 b2))), pc, 2
314   | (true,false,false,true),(false,false,true,true) ->
315         `MOVC (`A, `A_DPTR), pc, 2
316   | (true,false,false,false),(false,false,true,true) ->
317         `MOVC (`A, `A_PC), pc, 2
318   | (true,true,true,false),(false,false,true,i1) ->
319         `MOVX (`U1 (`A, `EXT_INDIRECT i1)), pc, 2
320   | (true,true,true,false),(false,false,false,false) ->
321         `MOVX (`U1 (`A, `EXT_IND_DPTR)), pc, 2
322   | (true,true,true,true),(false,false,true,i1) ->
323         `MOVX (`U2 (`EXT_INDIRECT i1, `A)), pc, 2
324   | (true,true,true,true),(false,false,false,false) ->
325         `MOVX (`U2 (`EXT_IND_DPTR, `A)), pc, 2
326   | (true,false,true,false),(false,true,false,false) ->
327         `MUL(`A, `B), pc, 4
328   | (false,false,false,false),(false,false,false,false) ->
329         `NOP, pc, 1
330   | (false,true,false,false),(true,r1,r2,r3) ->
331         `ORL (`U1(`A, `REG(r1,r2,r3))), pc, 1
332   | (false,true,false,false),(false,true,false,true) ->
333       let pc,b1 = next pc in
334         `ORL (`U1(`A, `DIRECT b1)), pc, 1
335   | (false,true,false,false),(false,true,true,i1) ->
336         `ORL (`U1(`A, `INDIRECT i1)), pc, 1
337   | (false,true,false,false),(false,true,false,false) ->
338       let pc,b1 = next pc in
339         `ORL (`U1(`A, `DATA b1)), pc, 1
340   | (false,true,false,false),(false,false,true,false) ->
341       let pc,b1 = next pc in
342         `ORL (`U2(`DIRECT b1, `A)), pc, 1
343   | (false,true,false,false),(false,false,true,true) ->
344       let pc,b1 = next pc in
345       let pc,b2 = next pc in
346         `ORL (`U2 (`DIRECT b1, `DATA b2)), pc, 2
347   | (false,true,true,true),(false,false,true,false) ->
348       let pc,b1 = next pc in
349         `ORL (`U3 (`C, `BIT b1)), pc, 2
350   | (true,false,true,false),(false,false,false,false) ->
351       let pc,b1 = next pc in
352         `ORL (`U3 (`C, `NBIT b1)), pc, 2
353   | (true,true,false,true),(false,false,false,false) ->
354       let pc,b1 = next pc in
355         `POP (`DIRECT b1), pc, 2
356   | (true,true,false,false),(false,false,false,false) ->
357       let pc,b1 = next pc in
358         `PUSH (`DIRECT b1), pc, 2
359   | (false,false,true,false),(false,false,true,false) ->
360         `RET, pc, 2
361   | (false,false,true,true),(false,false,true,false) ->
362         `RETI, pc, 2
363   | (false,false,true,false),(false,false,true,true) ->
364         `RL `A, pc, 1
365   | (false,false,true,true),(false,false,true,true) ->
366         `RLC `A, pc, 1
367   | (false,false,false,false),(false,false,true,true) ->
368         `RR `A, pc, 1
369   | (false,false,false,true),(false,false,true,true) ->
370         `RRC `A, pc, 1
371   | (true,true,false,true),(false,false,true,true) ->
372         `SETB `C, pc, 1
373   | (true,true,false,true),(false,false,true,false) ->
374       let pc,b1 = next pc in
375         `SETB (`BIT b1), pc, 1
376   | (true,false,false,false),(false,false,false,false) ->
377       let pc,b1 = next pc in
378         `SJMP (`REL b1), pc, 2
379   | (true,false,false,true),(true,r1,r2,r3) ->
380       `SUBB (`A, `REG(r1,r2,r3)), pc, 1
381   | (true,false,false,true),(false,true,false,true) ->
382       let pc,b1 = next pc in
383         `SUBB (`A, `DIRECT b1), pc, 1
384   | (true,false,false,true),(false,true,true,i1) ->
385         `SUBB (`A, `INDIRECT i1), pc, 1
386   | (true,false,false,true),(false,true,false,false) ->
387       let pc,b1 = next pc in
388         `SUBB (`A, `DATA b1), pc, 1
389   | (true,true,false,false),(false,true,false,false) ->
390         `SWAP `A, pc, 1
391   | (true,true,false,false),(true,r1,r2,r3) ->
392         `XCH (`A, `REG(r1,r2,r3)), pc, 1
393   | (true,true,false,false),(false,true,false,true) ->
394       let pc,b1 = next pc in
395         `XCH (`A, `DIRECT b1), pc, 1
396   | (true,true,false,false),(false,true,true,i1) ->
397         `XCH (`A, `INDIRECT i1), pc, 1
398   | (true,true,false,true),(false,true,true,i1) ->
399         `XCHD(`A, `INDIRECT i1), pc, 1
400   | (false,true,true,false),(true,r1,r2,r3) ->
401         `XRL(`U1(`A, `REG(r1,r2,r3))), pc, 1
402   | (false,true,true,false),(false,true,false,true) ->
403       let pc,b1 = next pc in
404         `XRL(`U1(`A, `DIRECT b1)), pc, 1
405   | (false,true,true,false),(false,true,true,i1) ->
406         `XRL(`U1(`A, `INDIRECT i1)), pc, 1
407   | (false,true,true,false),(false,true,false,false) ->
408       let pc,b1 = next pc in
409         `XRL(`U1(`A, `DATA b1)), pc, 1
410   | (false,true,true,false),(false,false,true,false) ->
411       let pc,b1 = next pc in
412         `XRL(`U2(`DIRECT b1, `A)), pc, 1
413   | (false,true,true,false),(false,false,true,true) ->
414       let pc,b1 = next pc in
415       let pc,b2 = next pc in
416         `XRL(`U2(`DIRECT b1, `DATA b2)), pc, 2
417   | _,_ -> assert false
418;;
419
420let assembly1 =
421 function
422    `ACALL (`ADDR11 w) ->
423      let (a10,a9,a8,b1) = from_word11 w in
424        [mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
425  | `ADD (`A,`REG (r1,r2,r3)) ->
426     [mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
427  | `ADD (`A, `DIRECT b1) ->
428     [mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
429  | `ADD (`A, `INDIRECT i1) ->
430     [mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
431  | `ADD (`A, `DATA b1) ->
432     [mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
433  | `ADDC (`A, `REG(r1,r2,r3)) ->
434     [mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
435  | `ADDC (`A, `DIRECT b1) ->
436     [mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
437  | `ADDC (`A,`INDIRECT i1) ->
438     [mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
439  | `ADDC (`A,`DATA b1) ->
440     [mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
441  | `AJMP (`ADDR11 w) ->
442     let (a10,a9,a8,b1) = from_word11 w in
443       [mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true))]
444  | `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
445     [mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
446  | `ANL (`U1 (`A, `DIRECT b1)) ->
447     [mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
448  | `ANL (`U1 (`A, `INDIRECT i1)) ->
449     [mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
450  | `ANL (`U1 (`A, `DATA b1)) ->
451     [mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
452  | `ANL (`U2 (`DIRECT b1,`A)) ->
453     [mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
454  | `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
455     [mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
456  | `ANL (`U3 (`C,`BIT b1)) ->
457     [mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
458  | `ANL (`U3 (`C,`NBIT b1)) ->
459    [mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
460  | `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
461    [mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
462  | `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
463    [mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
464  | `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
465    [mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
466  | `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
467    [mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
468  | `CLR `A ->
469    [mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
470  | `CLR `C ->
471    [mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
472  | `CLR (`BIT b1) ->
473    [mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
474  | `CPL `A ->
475    [mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
476  | `CPL `C ->
477    [mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
478  | `CPL (`BIT b1) ->
479    [mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
480  | `DA `A ->
481    [mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
482  | `DEC `A ->
483    [mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
484  | `DEC (`REG(r1,r2,r3)) ->
485    [mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
486  | `DEC (`DIRECT b1) ->
487    [mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
488  | `DEC (`INDIRECT i1) ->
489    [mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
490  | `DIV (`A, `B) ->
491    [mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
492  | `DJNZ (`REG(r1,r2,r3), `REL b1) ->
493    [mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
494  | `DJNZ (`DIRECT b1, `REL b2) ->
495    [mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
496  | `INC `A ->
497    [mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
498  | `INC (`REG(r1,r2,r3)) ->
499    [mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
500  | `INC (`DIRECT b1) ->
501    [mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
502  | `INC (`INDIRECT i1) ->
503    [mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
504  | `INC `DPTR ->
505    [mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
506  | `JB (`BIT b1, `REL b2) ->
507    [mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
508  | `JBC (`BIT b1, `REL b2) ->
509    [mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
510  | `JC (`REL b1) ->
511    [mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
512  | `JMP `IND_DPTR ->
513    [mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
514  | `JNB (`BIT b1, `REL b2) ->
515    [mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
516  | `JNC (`REL b1) ->
517    [mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
518  | `JNZ (`REL b1) ->
519    [mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
520  | `JZ (`REL b1) ->
521    [mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
522  | `LCALL (`ADDR16 w) ->
523      let (b1,b2) = from_word w in
524        [mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
525  | `LJMP (`ADDR16 w) ->
526      let (b1,b2) = from_word w in
527        [mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
528  | `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
529    [mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
530  | `MOV (`U1 (`A, `DIRECT b1)) ->
531    [mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
532  | `MOV (`U1 (`A, `INDIRECT i1)) ->
533    [mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
534  | `MOV (`U1 (`A, `DATA b1)) ->
535    [mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
536  | `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
537    [mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
538  | `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
539    [mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
540  | `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
541    [mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
542  | `MOV (`U3 (`DIRECT b1, `A)) ->
543    [mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
544  | `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
545    [mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
546  | `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
547    [mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
548  | `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
549    [mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
550  | `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
551    [mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
552  | `MOV (`U2 (`INDIRECT i1, `A)) ->
553    [mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
554  | `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
555    [mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
556  | `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
557    [mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
558  | `MOV (`U5 (`C, `BIT b1)) ->
559    [mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
560  | `MOV (`U6 (`BIT b1, `C)) ->
561    [mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
562  | `MOV (`U4 (`DPTR, `DATA16 w)) ->
563    let (b1,b2) = from_word w in
564      [mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
565  | `MOVC (`A, `A_DPTR) ->
566    [mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
567  | `MOVC (`A, `A_PC) ->
568    [mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
569  | `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
570    [mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
571  | `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
572    [mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
573  | `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
574    [mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
575  | `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
576    [mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
577  | `MUL(`A, `B) ->
578    [mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
579  | `NOP ->
580    [mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
581  | `ORL (`U1(`A, `REG(r1,r2,r3))) ->
582    [mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
583  | `ORL (`U1(`A, `DIRECT b1)) ->
584    [mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
585  | `ORL (`U1(`A, `INDIRECT i1)) ->
586    [mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
587  | `ORL (`U1(`A, `DATA b1)) ->
588    [mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
589  | `ORL (`U2(`DIRECT b1, `A)) ->
590    [mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
591  | `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
592    [mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
593  | `ORL (`U3 (`C, `BIT b1)) ->
594    [mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
595  | `ORL (`U3 (`C, `NBIT b1)) ->
596    [mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
597  | `POP (`DIRECT b1) ->
598    [mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
599  | `PUSH (`DIRECT b1) ->
600    [mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
601  | `RET ->
602    [mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
603  | `RETI ->
604    [mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
605  | `RL `A ->
606    [mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
607  | `RLC `A ->
608    [mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
609  | `RR `A ->
610    [mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
611  | `RRC `A ->
612    [mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
613  | `SETB `C ->
614    [mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
615  | `SETB (`BIT b1) ->
616    [mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
617  | `SJMP (`REL b1) ->
618    [mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
619  | `SUBB (`A, `REG(r1,r2,r3)) ->
620    [mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
621  | `SUBB (`A, `DIRECT b1) ->
622    [mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
623  | `SUBB (`A, `INDIRECT i1) ->
624    [mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
625  | `SUBB (`A, `DATA b1) ->
626    [mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
627  | `SWAP `A ->
628    [mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
629  | `XCH (`A, `REG(r1,r2,r3)) ->
630    [mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
631  | `XCH (`A, `DIRECT b1) ->
632    [mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
633  | `XCH (`A, `INDIRECT i1) ->
634    [mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
635  | `XCHD(`A, `INDIRECT i1) ->
636    [mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
637  | `XRL(`U1(`A, `REG(r1,r2,r3))) ->
638    [mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
639  | `XRL(`U1(`A, `DIRECT b1)) ->
640    [mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
641  | `XRL(`U1(`A, `INDIRECT i1)) ->
642    [mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
643  | `XRL(`U1(`A, `DATA b1)) ->
644    [mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
645  | `XRL(`U2(`DIRECT b1, `A)) ->
646    [mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
647  | `XRL(`U2(`DIRECT b1, `DATA b2)) ->
648    [mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
649;;
650
651let fold_lefti f =
652 let rec aux i acc =
653  function
654     [] -> acc
655   | he::tl -> aux (i+1) (f i acc he) tl
656 in
657  aux 0
658;;
659
660let load_code_memory = fold_lefti (fun i mem v -> WordMap.add (vect_of_int i `Sixteen) v mem) WordMap.empty
661
662let load l status = { status with code_memory = load_code_memory l }
663
664module StringMap = Map.Make(String);;
665
666let assembly l =
667 let pc,labels,costs =
668  List.fold_left
669   (fun (pc,labels,costs) i ->
670     match i with
671        `Label s -> pc, StringMap.add s pc labels, costs
672      | `Cost s -> pc, labels, StringMap.add s pc costs
673      | `Jmp s
674      | `Call s -> pc + 3, labels, costs  (*CSC: very stupid: always expand to worst opcode *)
675      | #instruction as i ->
676        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
677         assert (i = i');
678         (pc + int_of_vect pc',labels, costs)
679   ) (0,StringMap.empty,StringMap.empty) l
680 in
681  if pc >= 65536 then
682   raise CodeTooLarge
683  else
684      List.flatten (List.map
685         (function
686            `Label s -> []
687          | `Cost s -> []
688          | `Jmp s ->
689              let pc_offset = StringMap.find s labels in
690                assembly1 (`LJMP (`ADDR16 (vect_of_int pc_offset `Sixteen)))
691          | `Call s ->
692              let pc_offset = StringMap.find s labels in
693                assembly1 (`LCALL (`ADDR16 (vect_of_int pc_offset `Sixteen)))
694          | #instruction as i -> assembly1 i) l)
695;;
696
697let get_address_of_register status (b1,b2,b3) =
698 let bu,bl = from_byte status.psw in
699 let (_,_,rs1,rs0) = from_nibble bu in
700 let base =
701  match rs1,rs0 with
702     false,false -> 0x00
703   | false,true  -> 0x08
704   | true,false  -> 0x10
705   | true,true   -> 0x18
706 in
707   vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven
708;;
709
710let get_register status reg =
711  let addr = get_address_of_register status reg in
712    Byte7Map.find addr status.low_internal_ram
713;;
714
715let set_register status v reg =
716  let addr = get_address_of_register status reg in
717    { status with low_internal_ram =
718        Byte7Map.add addr v status.low_internal_ram }
719;;
720
721let get_arg_8 status = 
722 function
723    `DIRECT addr ->
724       let n0, n1 = from_byte addr in
725       (match from_nibble n0 with
726          (false,r1,r2,r3) ->
727            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
728        | (true,r1,r2,r3) ->
729             (*CSC: SFR access, TO BE IMPLEMENTED *)
730            assert false)
731  | `INDIRECT b ->
732       let (b1, b2) = from_byte (get_register status (false,false,b)) in
733         (match (from_nibble b1, b2) with 
734           (false,r1,r2,r3),b2 ->
735             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
736         | (true,r1,r2,r3),b2 ->
737             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
738  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
739  | `A -> status.acc
740  | `B -> status.b
741  | `DATA b -> b
742  | `A_DPTR ->
743       let dpr = mk_word status.dph status.dpl in
744       (* CSC: what is the right behaviour in case of overflow?
745          assert false for now. Try to understand what DEC really does *)
746       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
747         WordMap.find addr status.external_ram
748  | `A_PC ->
749       (* CSC: what is the right behaviour in case of overflow?
750          assert false for now *)
751       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
752         WordMap.find addr status.external_ram
753  | `IND_DPTR ->
754       let dpr = mk_word status.dph status.dpl in
755         WordMap.find dpr status.external_ram
756;;
757
758let get_arg_16 status =
759  function
760                `DATA16 w -> w
761
762let get_arg_1 status =
763  function
764    `BIT addr
765  | `NBIT addr as x ->
766     let n1, n2 = from_byte addr in
767     let res =
768      (match from_nibble n1 with
769         (false,r1,r2,r3) ->
770           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
771           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
772           let bit = get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) in
773             (match bit with
774               None -> assert false
775             | Some bit' -> bit')
776        | (true,r1,r2,r3) ->
777           (*CSC: SFR access, TO BE IMPLEMENTED *)
778           assert false)
779    in (match x with `BIT _ -> res | _ -> not res)
780  | `C -> get_cy_flag status
781
782let set_arg_1 status v =
783  function
784    `BIT addr ->
785      let n1, n2 = from_byte addr in
786      (match from_nibble n1 with
787         (false,r1,r2,r3) ->
788           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
789           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
790           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
791             (match n_bit with
792                None -> assert false
793              | Some n_bit' ->
794                  { status with low_internal_ram = Byte7Map.add addr' n_bit' status.low_internal_ram })
795                        | (true,r1,r2,r3) ->
796           (*CSC: SFR access, TO BE IMPLEMENTED *)
797           (* assert false for now. Try to understand what DEC really does *)
798           assert false)
799    | `C ->
800       let (n1,n2) = from_byte status.psw in
801       let (_,b2,b3,b4) = from_nibble n1 in
802         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
803
804let set_arg_8 status v =
805 function
806    `DIRECT addr ->
807      let (b1, b2) = from_byte addr in
808      (match from_nibble b1 with
809         (false,r1,r2,r3) ->
810           { status with low_internal_ram =
811              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
812       | (true,r1,r2,r3) ->
813           (*CSC: SFR access, TO BE IMPLEMENTED *)
814           (* assert false for now. Try to understand what DEC really does *)
815           assert false)
816  | `INDIRECT b ->
817     let (b1, b2) = from_byte (get_register status (false,false,b)) in
818     (match (from_nibble b1, b2) with 
819         (false,r1,r2,r3),n1 ->
820           { status with low_internal_ram =
821              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
822       | (true,r1,r2,r3),n1 ->
823           { status with high_internal_ram =
824              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
825  | `REG (b1,b2,b3) ->
826      set_register status v (b1,b2,b3)
827  | `A -> { status with acc = v }
828  | `B -> { status with b = v }
829  | `IND_DPTR ->
830     let dpr = mk_word status.dph status.dpl in
831      { status with external_ram =
832        WordMap.add dpr v status.external_ram }
833;;
834
835let set_arg_16 status wrd =
836        function
837                `DPTR ->
838       let (dh, dl) = from_word wrd in
839         { status with dph = dh; dpl = dl }
840
841let set_flags status c ac ov =
842 { status with psw =
843    let bu,bl = from_byte status.psw in
844    let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
845    let ac = match ac with None -> oac | Some v -> v in
846      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
847 }
848;;
849
850let xor b1 b2 =
851  if b1 = true && b2 = true then
852    false
853  else if b1 = false && b2 = false then
854    false
855  else true
856;;
857
858let ($) f x = f x
859
860let execute1 status =
861 let instr,pc,ticks = fetch status.code_memory status.pc in
862 let status = { status with clock = status.clock + ticks; pc = pc } in
863  match instr with
864     `ADD (`A,d1) ->
865        let v,c,ac,ov =
866          add8_with_c (get_arg_8 status `A) (get_arg_8 status d1) false
867        in
868          set_flags (set_arg_8 status v `A) c (Some ac) ov
869   | `ADDC (`A,d1) ->
870        let v,c,ac,ov =
871          add8_with_c (get_arg_8 status `A) (get_arg_8 status d1) (get_cy_flag status)
872        in
873          set_flags (set_arg_8 status v `A) c (Some ac) ov
874   | `SUBB (`A,d1) ->
875        let v,c,ac,ov =
876          subb8_with_c (get_arg_8 status `A) (get_arg_8 status d1) (get_cy_flag status)
877        in
878          set_flags (set_arg_8 status v `A) c (Some ac) ov
879   | `INC `DPTR ->
880       let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
881       let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
882         { status with dpl = low_order_byte; dph = high_order_byte }
883   | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
884       let b = get_arg_8 status d in
885       let cry, res = half_add b (vect_of_int 0 `Eight) in
886         set_arg_8 status res d
887   | `DEC d ->
888       let b = get_arg_8 status d in
889       let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
890         set_arg_8 status res d
891   | `MUL (`A,`B) ->
892       let acc = int_of_vect status.acc in
893       let b = int_of_vect status.b in
894       let prod = acc * b in
895       let ov = prod > 255 in
896       let l = vect_of_int (prod  mod 256) `Eight in
897       let h = vect_of_int (prod / 256) `Eight in
898       let status = { status with acc = l ; b = h } in
899         (* DPM: Carry flag is always cleared. *)
900         set_flags status false None ov
901   | `DIV (`A,`B) ->
902      let acc = int_of_vect status.acc in
903      let b = int_of_vect status.b in
904      if b = 0 then
905        (* CSC: ACC and B undefined! We leave them as they are. *)
906        set_flags status false None true
907      else
908        let q = vect_of_int (acc / b) `Eight in
909        let r = vect_of_int (acc mod b) `Eight in
910        let status = { status with acc = q ; b = r } in
911          set_flags status false None false
912   | `DA `A ->
913        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
914          if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
915            let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
916            let acc_upper_nibble, acc_lower_nibble = from_byte acc in
917            if int_of_vect acc_upper_nibble > 9 or cy = true then
918              let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
919              let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
920                set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
921            else
922              status
923          else
924            status
925   | `ANL (`U1(`A, ag)) ->
926        let and_val = get_arg_8 status `A -&- get_arg_8 status ag in
927          set_arg_8 status and_val `A
928   | `ANL (`U2((`DIRECT d), ag)) ->
929        let and_val = get_arg_8 status (`DIRECT d) -&- get_arg_8 status ag in
930          set_arg_8 status and_val `A
931   | `ANL (`U3 (`C, b)) ->
932        let and_val = get_cy_flag status && get_arg_1 status b in
933          set_flags status and_val None (get_ov_flag status)
934   | `ORL (`U1(`A, ag)) ->
935        let or_val = get_arg_8 status `A -|- get_arg_8 status ag in
936          set_arg_8 status or_val `A
937   | `ORL (`U2((`DIRECT d), ag)) ->
938        let or_val = get_arg_8 status (`DIRECT d) -|- get_arg_8 status ag in
939          set_arg_8 status or_val `A
940   | `ORL (`U3 (`C, b)) ->
941        let or_val = get_cy_flag status || get_arg_1 status b in
942          set_flags status or_val None (get_ov_flag status)
943   | `XRL (`U1(`A, ag)) ->
944        let xor_val = get_arg_8 status `A -^- get_arg_8 status ag in
945          set_arg_8 status xor_val `A
946   | `XRL (`U2((`DIRECT d), ag)) ->
947        let xor_val = get_arg_8 status (`DIRECT d) -^- get_arg_8 status ag in
948          set_arg_8 status xor_val `A
949   | `CLR `A -> set_arg_8 status (zero `Eight) `A
950   | `CLR `C -> set_arg_1 status false `C
951   | `CLR ((`BIT b) as a) -> set_arg_1 status false a
952   | `CPL `A -> { status with acc = complement status.acc }
953   | `CPL `C -> set_arg_1 status (not $ get_arg_1 status `C) `C
954   | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status b) b
955   | `RL `A -> { status with acc = rotate_left status.acc }
956   | `RLC `A ->
957        let old_cy = get_cy_flag status in
958        let n1, n2 = from_byte status.acc in
959        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
960        let status = set_arg_1 status b1 `C in
961          { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
962   | `RR `A -> { status with acc = rotate_right status.acc }
963   | `RRC `A ->
964        let old_cy = get_cy_flag status in
965        let n1, n2 = from_byte status.acc in
966        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
967        let status = set_arg_1 status b8 `C in
968          { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
969   | `SWAP `A ->
970        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
971          { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
972  | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
973  | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
974  | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
975  | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
976  | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status b2) b1
977  | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status b2) b1
978  | `MOVC (`A, `A_DPTR) ->
979     let big_acc = mk_word (zero `Eight) status.acc in
980     let dptr = mk_word status.dph status.dpl in
981     let cry, addr = half_add dptr big_acc in
982     let lookup = WordMap.find addr status.code_memory in
983       { status with acc = lookup }
984  | `MOVC (`A, `A_PC) ->
985     let big_acc = mk_word (zero `Eight) status.acc in
986     (* DPM: Under specified: does the carry from PC incrementation affect the *)
987     (*      addition of the PC with the DPTR? At the moment, no.              *)
988     let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
989     let status = { status with pc = inc_pc } in
990     let cry,addr = half_add inc_pc big_acc in
991     let lookup = WordMap.find addr status.code_memory in
992       { status with acc = lookup }
993 (* data transfer *)
994(*
995 | MOVX of (acc * [ indirect | indirect_dptr ],
996            [ indirect | indirect_dptr ] * acc) union2
997*)
998  | `SETB b -> set_arg_1 status true b
999  | `PUSH (`DIRECT b) ->
1000       (* DPM: What happens if we overflow? *)
1001       let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1002       let status = { status with sp = new_sp } in
1003       let memory = Byte7Map.add (byte7_of_byte status.sp) b status.low_internal_ram in
1004         { status with low_internal_ram = memory }
1005  | `POP (`DIRECT b) ->
1006       let contents = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1007       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1008       let status = { status with sp = new_sp } in
1009       let status = set_arg_8 status contents (`DIRECT b) in
1010         status
1011  | `XCH(`A, arg) ->
1012       let old_arg = get_arg_8 status arg in
1013       let old_acc = status.acc in
1014       let status = set_arg_8 status old_acc arg in
1015         { status with acc = old_arg }
1016  | `XCHD(`A, i) ->
1017       let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status `A in
1018       let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status i in
1019       let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1020       let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1021       let status = { status with acc = new_acc } in
1022         set_arg_8 status new_reg i
1023 (* program branching *)
1024  | `JC (`REL rel) ->
1025       if get_cy_flag status then
1026         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1027           { status with pc = new_pc }
1028       else
1029         status
1030  | `JNC (`REL rel) ->
1031       if not $ get_cy_flag status then
1032         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1033           { status with pc = new_pc }
1034       else
1035         status
1036  | `JB (b, (`REL rel)) ->
1037       if get_arg_1 status b then
1038         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1039           { status with pc = new_pc }
1040       else
1041         status
1042  | `JNB (b, (`REL rel)) ->
1043       if not $ get_arg_1 status b then
1044         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1045           { status with pc = new_pc }
1046       else
1047         status
1048  | `JBC (b, (`REL rel)) ->
1049       let status = set_arg_1 status false b in
1050         if get_arg_1 status b then
1051           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1052             { status with pc = new_pc }
1053         else
1054           status
1055  | `RET ->
1056      (* DPM: What happens when we underflow? *)
1057       let high_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1058       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1059       let status = { status with sp = new_sp } in
1060       let low_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1061       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1062       let status = { status with sp = new_sp } in
1063         { status with pc = mk_word high_bits low_bits }
1064  | `RETI ->
1065       let high_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1066       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1067       let status = { status with sp = new_sp } in
1068       let low_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1069       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1070       let status = { status with sp = new_sp } in
1071         { status with pc = mk_word high_bits low_bits }
1072  | `ACALL (`ADDR11 a) ->
1073       let cry, new_pc = half_add status.pc (vect_of_int 2 `Sixteen) in
1074       let status = { status with pc = new_pc } in
1075       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1076       let status = { status with sp = new_sp } in
1077       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1078       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_lower_byte status.low_internal_ram in
1079       let status = { status with low_internal_ram = lower_mem } in
1080       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1081       let status = { status with sp = new_sp } in
1082       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_upper_byte status.low_internal_ram in
1083       let status = { status with low_internal_ram = lower_mem } in
1084       let n1, n2 = from_byte pc_upper_byte in
1085       let (b1,b2,b3,b) = from_word11 a in
1086       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1087       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in
1088         { status with pc = addr }
1089  | `LCALL (`ADDR16 addr) ->
1090       let cry, new_pc = half_add status.pc (vect_of_int 3 `Sixteen) in
1091       let status = { status with pc = new_pc } in
1092       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1093       let status = { status with sp = new_sp } in
1094       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1095       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_upper_byte status.low_internal_ram in
1096       let status = { status with low_internal_ram = lower_mem } in
1097       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1098       let status = { status with sp = new_sp } in
1099       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_lower_byte status.low_internal_ram in
1100       let status = { status with low_internal_ram = lower_mem } in
1101         { status with pc = addr }
1102  | `AJMP (`ADDR11 a) ->
1103       let cry, new_pc = half_add status.pc (vect_of_int 2 `Sixteen) in
1104       let status = { status with pc = new_pc } in
1105       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1106       let n1, n2 = from_byte pc_upper_byte in
1107       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1108       let (b1,b2,b3,b) = from_word11 a in
1109       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in
1110       let cry, new_pc = half_add status.pc addr in
1111         { status with pc = new_pc }
1112  | `LJMP (`ADDR16 a) ->
1113       { status with pc = a }
1114  | `SJMP (`REL rel) ->
1115       let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1116         { status with pc = new_pc }
1117  | `JMP `IND_DPTR ->
1118       let dptr = mk_word status.dph status.dpl in
1119       let big_acc = mk_word (zero `Eight) status.acc in
1120       let cry, jmp_addr = half_add big_acc dptr in
1121       let cry, new_pc = half_add status.pc jmp_addr in
1122         { status with pc = new_pc }
1123  | `JZ (`REL rel) ->
1124       if status.acc = zero `Eight then
1125         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1126           { status with pc = new_pc }
1127       else
1128         status
1129  | `JNZ (`REL rel) ->
1130       if status.acc <> zero `Eight then
1131         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1132                           { status with pc = new_pc }
1133       else
1134         status
1135  | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1136       let new_carry = status.acc < get_arg_8 status ag in
1137         if get_arg_8 status ag <> status.acc then
1138           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1139           let status = set_flags status new_carry None (get_ov_flag status) in
1140             { status with pc = new_pc;  }
1141         else
1142           set_flags status new_carry None (get_ov_flag status)
1143  | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1144     let new_carry = get_arg_8 status ag < d in
1145       if get_arg_8 status ag <> d then
1146         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1147         let status = { status with pc = new_pc } in
1148           set_flags status new_carry None (get_ov_flag status)
1149       else
1150         set_flags status new_carry None (get_ov_flag status)
1151  | `DJNZ (ag, (`REL rel)) ->
1152       let new_ag,_,_,_ = subb8_with_c (get_arg_8 status ag) (vect_of_int 1 `Eight) false in
1153       let status = set_arg_8 status new_ag ag in
1154         if new_ag <> zero `Eight then
1155           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1156             { status with pc = new_pc }
1157         else
1158           status
1159  | `NOP -> status
1160  | _ -> assert false (* DPM: Until MOVX implemented. *)
1161;;
1162
1163let rec execute f s =
1164 let s = execute1 s in
1165 let cont =
1166  try f s; true
1167  with Halt -> false
1168 in
1169  if cont then execute f s
1170  else s
1171;;
Note: See TracBrowser for help on using the repository browser.