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

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

Rough implementation of direct (i.e. no BIT) SFR access.
Note: I/O is not handled properly. Thus the current implementation only
makes sense for real registers like SP, PSW, etc.

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