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

Last change on this file since 138 was 138, checked in by sacerdot, 9 years ago

Several bug fixes and code clean-up.
New main file: test.ml to parse and execute an HEX file.
Usage: ./test.native foo.hex

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