source: Deliverables/D2.2/8051-indexed-labels-branch/src/ASM/ASMInterpret.ml @ 1349

Last change on this file since 1349 was 1349, checked in by tranquil, 9 years ago
  • work on LIN completed
  • small implementation of extensible arrays
File size: 80.4 KB
Line 
1open BitVectors;;
2open Physical;;
3open ASM;;
4open IntelHex;;
5open Util;;
6open Parser;;
7
8exception Fetch_exception of string;;
9exception CodeTooLarge;;
10exception Halt;;
11
12type time = int;;
13type line = [ `P1 of byte
14            | `P3 of byte
15            | `SerialBuff of [ `Eight of byte | `Nine of BitVectors.bit * byte ]];;
16
17let string_of_line =
18  function
19  `P1 b ->
20    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
21      "P1 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
22      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
23    | `P3 b ->
24      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
25        "P2 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
26        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
27    | `SerialBuff (`Eight b) ->
28      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
29        "SERIAL 8b OUTPUT: " ^ string_of_vect b ^ "\n" ^
30        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
31    | `SerialBuff (`Nine (b, b')) ->
32      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
33        "SERIAL 9b OUTPUT: " ^
34        (let i = int_of_vect b' in
35         if b then
36           string_of_int (128 + i)
37         else
38           string_of_int i) ^
39        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
40
41(* In:  reception time, line of input, new continuation,
42   Out: transmission time, output line, expected duration until reply,
43        new continuation.
44*)
45
46type epsilon = int
47
48type continuation =
49  [`In of time * line * epsilon * continuation] option *
50    [`Out of (time -> line -> time * continuation)]
51
52let rec debug_continuation =
53  (Some (`In (1, (`SerialBuff (`Eight (vect_of_int 5 `Eight))), 0, debug_continuation))), `Out (
54    fun time line ->
55      (* let _ = prerr_endline <*> string_of_line $ line in *)
56      (time + 1),debug_continuation)
57   
58(* no differentiation between internal and external code memory *)
59type status =
60{
61  (* Memory *)
62  code_memory: Physical.WordMap.map;        (* can be reduced *)
63  low_internal_ram: Byte7Map.map;
64  high_internal_ram: Byte7Map.map;
65  external_ram: Physical.WordMap.map;
66
67  (* Program counter *)
68  pc: word;
69
70  (* SFRs *)
71  sp: byte;
72  dpl: byte;
73  dph: byte;
74  pcon: byte;
75  tcon: byte;
76  tmod: byte;
77  tl0: byte;
78  tl1: byte;
79  th0: byte;
80  th1: byte;
81  p1: byte;
82  scon: byte;
83  sbuf: byte;
84  ie: byte;
85  p3: byte;
86  ip: byte;
87  psw: byte;
88  acc: byte;
89  b: byte;
90  t2con: byte;   (* 8052 only *)
91  rcap2l: byte;  (* 8052 only *)
92  rcap2h: byte;  (* 8052 only *)
93  tl2: byte;     (* 8052 only *)
94  th2: byte;     (* 8052 only *)
95
96  (* Latches for the output lines *)
97  p1_latch: byte;
98  p3_latch: byte;
99
100  (* Fields for tracking the state of the processor. *)
101 
102  (* IO specific *)
103  previous_p1_val: bool;
104  previous_p3_val: bool;
105
106  serial_epsilon_out: epsilon option;
107  serial_epsilon_in: epsilon option;
108
109  io_epsilon: epsilon;
110
111  serial_v_in: [`Eight of byte | `Nine of (BitVectors.bit * byte) ] option;
112  serial_v_out: [`Eight of byte | `Nine of (BitVectors.bit * byte) ] option;
113
114  serial_k_out: continuation option;
115
116  io: continuation;
117  expected_out_time: [ `None | `Now | `At of time ];
118
119  (* Timer and clock specific *)
120  clock: time;
121  timer0: word;
122  timer1: word;
123  timer2: word;  (* can be missing *)
124
125  esi_running: bool;
126  t0i_running: bool;
127  t1i_running: bool;
128  e0i_running: bool;
129  e1i_running: bool;
130  es_running: bool;
131
132  exit_addr   : BitVectors.word;
133       
134        ind_0s      : int BitVectors.WordMap.t;
135  ind_incs    : int BitVectors.WordMap.t;
136  cost_labels : CostLabel.t BitVectors.WordMap.t
137}
138
139(* Try to understand what DEC really does!!! *)
140(* Try to understand I/O *)
141let get_sfr status addr from_latch =
142  match int_of_vect addr with
143    (* I/O and timer ports *)
144      0x80 -> assert false (* P0 not modeled *)
145    | 0x90 ->
146      if from_latch then
147        status.p1_latch
148      else status.p1
149    | 0xA0 -> assert false (* P2 not modeled *)
150    | 0xB0 ->
151      if from_latch then
152        status.p3_latch
153      else status.p3
154    | 0x99 -> status.sbuf
155    | 0x8A -> status.tl0
156    | 0x8B -> status.tl1
157    | 0x8C -> status.th0
158    | 0x8D -> status.th1
159    | 0xC8 -> status.t2con
160    | 0xCA -> status.rcap2l
161    | 0xCB -> status.rcap2h
162    | 0xCC -> status.tl2
163    | 0xCD -> status.th2
164
165  (* control ports *)
166    | 0x87 -> status.pcon
167    | 0x88 -> status.tcon
168    | 0x89 -> status.tmod
169    | 0x98 -> status.scon
170    | 0xA8 -> status.ie
171    | 0xB8 -> status.ip
172     
173  (* registers *)
174    | 0x81 -> status.sp
175    | 0x82 -> status.dpl
176    | 0x83 -> status.dph
177    | 0xD0 -> status.psw
178    | 0xE0 -> status.acc
179    | 0xF0 -> status.b
180    | _ -> assert false
181;;
182
183(* Try to understand I/O *)
184let set_sfr status addr v =
185  match int_of_vect addr with
186    (* I/O and timer ports *)
187      0x80 -> assert false (* P0 not modeled *)
188    | 0x90 -> { status with p1 = v; p1_latch = v }
189    | 0xA0 -> assert false (* P2 not modeled *)
190    | 0xB0 -> { status with p3 = v; p3_latch = v }
191    | 0x99 ->
192      if status.expected_out_time = `None then
193        { status with sbuf = v; expected_out_time = `Now }
194      else
195        (* a real assert false: trying to initiate a transmission whilst one is still active *)
196        assert false
197    | 0x8A -> { status with tl0 = v }
198    | 0x8B -> { status with tl1 = v }
199    | 0x8C -> { status with th0 = v }
200    | 0x8D -> { status with th1 = v }
201    | 0xC8 -> { status with t2con = v }
202    | 0xCA -> { status with rcap2l = v }
203    | 0xCB -> { status with rcap2h = v }
204    | 0xCD -> { status with tl2 = v }
205    | 0xCE -> { status with th2 = v }
206
207    (* control ports *)
208    | 0x87 -> { status with pcon = v }
209    | 0x88 -> { status with tcon = v }
210    | 0x89 -> { status with tmod = v }
211    | 0x98 -> { status with scon = v }
212    | 0xA8 -> { status with ie = v }
213    | 0xB8 -> { status with ip = v }
214     
215    (* registers *)
216    | 0x81 -> { status with sp = v }
217    | 0x82 -> { status with dpl = v }
218    | 0x83 -> { status with dph = v }
219    | 0xD0 -> { status with psw = v }
220    | 0xE0 -> { status with acc = v }
221    | 0xF0 -> { status with b = v }
222    | _ -> assert false
223;;
224
225let initialize = {
226  code_memory = Physical.WordMap.empty;
227  low_internal_ram = Byte7Map.empty;
228  high_internal_ram = Byte7Map.empty;
229  external_ram = Physical.WordMap.empty;
230 
231  pc = zero `Sixteen;
232 
233  sp = vect_of_int 7 `Eight;
234  dpl = zero `Eight;
235  dph = zero `Eight;
236  pcon = zero `Eight;
237  tcon = zero `Eight;
238  tmod = zero `Eight;
239  tl0 = zero `Eight;
240  tl1 = zero `Eight;
241  th0 = zero `Eight;
242  th1 = zero `Eight;
243  p1 = zero `Eight;
244  p1_latch = zero `Eight;
245  scon = zero `Eight;
246  sbuf = zero `Eight;
247  ie = zero `Eight;
248  p3 = zero `Eight;
249  p3_latch = zero `Eight;
250  ip = zero `Eight;
251  psw = zero `Eight;
252  acc = zero `Eight;
253  b = zero `Eight;
254  t2con = zero `Eight;
255  rcap2l = zero `Eight;
256  rcap2h = zero `Eight;
257  tl2 = zero `Eight;
258  th2 = zero `Eight;
259
260  previous_p1_val = false;
261  previous_p3_val = false;
262
263  serial_v_in = None;
264  serial_v_out = None;
265  serial_epsilon_in = None;
266  serial_epsilon_out = None;
267  serial_k_out = None;
268
269  io_epsilon = 5;
270
271  clock = 0;
272  timer0 = zero `Sixteen;
273  timer1 = zero `Sixteen;
274  timer2 = zero `Sixteen;
275
276  expected_out_time = `None;
277
278  io = debug_continuation; (* a real assert false: unprepared for i/o *)
279
280  (* Initially no interrupts are executing *)
281  esi_running = false;
282  t0i_running = false;
283  t1i_running = false;
284  e0i_running = false;
285  e1i_running = false;
286  es_running = false;
287
288  exit_addr = BitVectors.zero `Sixteen;
289  ind_0s = BitVectors.WordMap.empty;
290  ind_incs = BitVectors.WordMap.empty;
291  cost_labels = BitVectors.WordMap.empty
292}
293
294let get_cy_flag status =
295  let (cy,_,_,_),(_,_,_,_) = bits_of_byte status.psw in cy
296let get_ac_flag status =
297  let (_,ac,_,_),(_,_,_,_) = bits_of_byte status.psw in ac
298let get_fo_flag status =
299  let (_,_,fo,_),(_,_,_,_) = bits_of_byte status.psw in fo
300let get_rs1_flag status =
301  let (_,_,_,rs1),(_,_,_,_) = bits_of_byte status.psw in rs1
302let get_rs0_flag status =
303  let (_,_,_,_),(rs0,_,_,_) = bits_of_byte status.psw in rs0
304let get_ov_flag status =
305  let (_,_,_,_),(_,ov,_,_) = bits_of_byte status.psw in ov
306let get_ud_flag status =
307  let (_,_,_,_),(_,_,ud,_) = bits_of_byte status.psw in ud
308let get_p_flag status =
309  let (_,_,_,_),(_,_,_,p) = bits_of_byte status.psw in p
310
311let get_address_of_register status (b1,b2,b3) =
312  let bu,_bl = from_byte status.psw in
313  let (_,_,rs1,rs0) = from_nibble bu in
314  let base =
315    match rs1,rs0 with
316        false,false -> 0x00
317      | false,true  -> 0x08
318      | true,false  -> 0x10
319      | true,true   -> 0x18
320  in
321  vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven
322;;
323
324let get_register status reg =
325  let addr = get_address_of_register status reg in
326  Byte7Map.find addr status.low_internal_ram
327;;
328
329let string_of_status status =   
330  let acc_str = (string_of_int <*> int_of_vect $ status.acc) ^ " (" ^ string_of_vect status.acc ^ ")" in
331  let b_str   = (string_of_int <*> int_of_vect $ status.b) ^ " (" ^ string_of_vect status.b ^ ")" in
332  let psw_str = (string_of_int <*> int_of_vect $ status.psw) ^ " (" ^ string_of_vect status.psw ^ ")" in
333  let sp_str  = (string_of_int <*> int_of_vect $ status.sp) ^ " (" ^ string_of_vect status.sp ^ ")" in
334  let ip_str  = (string_of_int <*> int_of_vect $ status.ip) ^ " (" ^ string_of_vect status.ip ^ ")" in
335  let pc_str  = (string_of_int <*> int_of_vect $ status.pc) ^ " (" ^ string_of_vect status.pc ^ ")" in
336  let dpl_str = (string_of_int <*> int_of_vect $ status.dpl) ^ " (" ^ string_of_vect status.dpl ^ ")" in
337  let dph_str = (string_of_int <*> int_of_vect $ status.dph) ^ " (" ^ string_of_vect status.dph ^ ")" in
338  let scn_str = (string_of_int <*> int_of_vect $ status.scon) ^ " (" ^ string_of_vect status.scon ^ ")" in
339  let sbf_str = (string_of_int <*> int_of_vect $ status.sbuf) ^ " (" ^ string_of_vect status.sbuf ^ ")" in
340  let tcn_str = (string_of_int <*> int_of_vect $ status.tcon) ^ " (" ^ string_of_vect status.tcon ^ ")" in
341  let tmd_str = (string_of_int <*> int_of_vect $ status.tmod) ^ " (" ^ string_of_vect status.tmod ^ ")" in
342  let r0_str  = (string_of_int <*> int_of_vect $ get_register status (false, false, false)) ^ " (" ^ (string_of_vect $ get_register status (false, false, false)) ^ ")" in
343  let r1_str  = (string_of_int <*> int_of_vect $ get_register status (false, false, true)) ^ " (" ^ (string_of_vect $ get_register status (false, false, true)) ^ ")" in
344  let r2_str  = (string_of_int <*> int_of_vect $ get_register status (false, true, false)) ^ " (" ^ (string_of_vect $ get_register status (false, true, false)) ^ ")" in
345  let r3_str  = (string_of_int <*> int_of_vect $ get_register status (false, true, true)) ^ " (" ^ (string_of_vect $ get_register status (false, true, true)) ^ ")" in
346  let r4_str  = (string_of_int <*> int_of_vect $ get_register status (true, false, false)) ^ " (" ^ (string_of_vect $ get_register status (true, false, false)) ^ ")" in
347  let r5_str  = (string_of_int <*> int_of_vect $ get_register status (true, false, true)) ^ " (" ^ (string_of_vect $ get_register status (true, false, true)) ^ ")" in
348  let r6_str  = (string_of_int <*> int_of_vect $ get_register status (true, true, false)) ^ " (" ^ (string_of_vect $ get_register status (true, true, false)) ^ ")" in
349  let r7_str  = (string_of_int <*> int_of_vect $ get_register status (true, true, true)) ^ " (" ^ (string_of_vect $ get_register status (true, true, true)) ^ ")" in
350    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
351    " Processor status:                               \n" ^
352    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
353    "   ACC : " ^ acc_str ^ "\n"                          ^
354    "   B   : " ^ b_str   ^ "\n"                          ^
355    "   PSW : " ^ psw_str ^ "\n"                          ^
356    "    with flags set as                            \n" ^
357    "     CY  : " ^ (string_of_bool <*> get_cy_flag $ status) ^ "\n" ^
358    "     AC  : " ^ (string_of_bool <*> get_ac_flag $ status) ^ "\n" ^
359    "     FO  : " ^ (string_of_bool <*> get_fo_flag $ status) ^ "\n" ^
360    "     RS1 : " ^ (string_of_bool <*> get_rs1_flag $ status) ^ "\n" ^
361    "     RS0 : " ^ (string_of_bool <*> get_rs0_flag $ status) ^ "\n" ^
362    "     OV  : " ^ (string_of_bool <*> get_ov_flag $ status) ^ "\n" ^
363    "     UD  : " ^ (string_of_bool <*> get_ud_flag $ status) ^ "\n" ^
364    "     P   : " ^ (string_of_bool <*> get_p_flag $ status) ^ "\n" ^
365    "   SP  : " ^ sp_str  ^ "\n"                          ^
366    "   IP  : " ^ ip_str  ^ "\n"                          ^
367    "   PC  : " ^ pc_str  ^ "\n"                          ^
368    "   DPL : " ^ dpl_str ^ "\n"                          ^
369    "   DPH : " ^ dph_str ^ "\n"                          ^
370    "   SCON: " ^ scn_str ^ "\n"                          ^
371    "   SBUF: " ^ sbf_str ^ "\n"                          ^
372    "   TMOD: " ^ tmd_str ^ "\n"                          ^
373    "   TCON: " ^ tcn_str ^ "\n"                          ^
374    "   Registers:                                    \n" ^
375    "    R0 : " ^ r0_str  ^ "\n"                          ^
376    "    R1 : " ^ r1_str  ^ "\n"                          ^
377    "    R2 : " ^ r2_str  ^ "\n"                          ^
378    "    R3 : " ^ r3_str  ^ "\n"                          ^
379    "    R4 : " ^ r4_str  ^ "\n"                          ^
380    "    R5 : " ^ r5_str  ^ "\n"                          ^
381    "    R6 : " ^ r6_str  ^ "\n"                          ^
382    "    R7 : " ^ r7_str  ^ "\n"                          ^
383    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
384
385(* timings taken from SIEMENS *)
386
387let fetch pmem pc =
388  let next pc =
389    let _carry, res = half_add pc (vect_of_int 1 `Sixteen) in
390    res, Physical.WordMap.find pc pmem
391  in
392  let pc,instr = next pc in
393  let un, ln = from_byte instr in
394  let bits = (from_nibble un, from_nibble ln) in
395  match bits with
396      (a10,a9,a8,true),(false,false,false,true) ->
397        let pc,b1 = next pc in
398        `ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
399    | (false,false,true,false),(true,r1,r2,r3) ->
400      `ADD (`A,`REG (r1,r2,r3)), pc, 1
401    | (false,false,true,false),(false,true,false,true) ->
402      let pc,b1 = next pc in
403      `ADD (`A,`DIRECT b1), pc, 1
404    | (false,false,true,false),(false,true,true,i1) ->
405      `ADD (`A,`INDIRECT i1), pc, 1
406    | (false,false,true,false),(false,true,false,false) ->
407      let pc,b1 = next pc in
408      `ADD (`A,`DATA b1), pc, 1
409    | (false,false,true,true),(true,r1,r2,r3) ->
410      `ADDC (`A,`REG (r1,r2,r3)), pc, 1
411    | (false,false,true,true),(false,true,false,true) ->
412      let pc,b1 = next pc in
413      `ADDC (`A,`DIRECT b1), pc, 1
414    | (false,false,true,true),(false,true,true,i1) ->
415      `ADDC (`A,`INDIRECT i1), pc, 1
416    | (false,false,true,true),(false,true,false,false) ->
417      let pc,b1 = next pc in
418      `ADDC (`A,`DATA b1), pc, 1
419    | (a10,a9,a8,false),(false,false,false,true) ->
420      let pc,b1 = next pc in
421      `AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
422    | (false,true,false,true),(true,r1,r2,r3) ->
423      `ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1
424    | (false,true,false,true),(false,true,false,true) ->
425      let pc,b1 = next pc in
426      `ANL (`U1 (`A, `DIRECT b1)), pc, 1
427    | (false,true,false,true),(false,true,true,i1) ->
428      `ANL (`U1 (`A, `INDIRECT i1)), pc, 1
429    | (false,true,false,true),(false,true,false,false) ->
430      let pc,b1 = next pc in
431      `ANL (`U1 (`A, `DATA b1)), pc, 1
432    | (false,true,false,true),(false,false,true,false) ->
433      let pc,b1 = next pc in
434      `ANL (`U2 (`DIRECT b1,`A)), pc, 1
435    | (false,true,false,true),(false,false,true,true) ->
436      let pc,b1 = next pc in
437      let pc,b2 = next pc in
438      `ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2
439    | (true,false,false,false),(false,false,true,false) ->
440      let pc,b1 = next pc in
441      `ANL (`U3 (`C,`BIT b1)), pc, 2
442    | (true,false,true,true),(false,false,false,false) ->
443      let pc,b1 = next pc in
444      `ANL (`U3 (`C,`NBIT b1)), pc, 2
445    | (true,false,true,true),(false,true,false,true) ->
446      let pc,b1 = next pc in
447      let pc,b2 = next pc in
448      `CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2
449    | (true,false,true,true),(false,true,false,false) ->
450      let pc,b1 = next pc in
451      let pc,b2 = next pc in
452      `CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2
453    | (true,false,true,true),(true,r1,r2,r3) ->
454      let pc,b1 = next pc in
455      let pc,b2 = next pc in
456      `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2
457    | (true,false,true,true),(false,true,true,i1) ->
458      let pc,b1 = next pc in
459      let pc,b2 = next pc in
460      `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2
461    | (true,true,true,false),(false,true,false,false) ->
462      `CLR `A, pc, 1
463    | (true,true,false,false),(false,false,true,true) ->
464      `CLR `C, pc, 1
465    | (true,true,false,false),(false,false,true,false) ->
466      let pc,b1 = next pc in
467      `CLR (`BIT b1), pc, 1
468    | (true,true,true,true),(false,true,false,false) ->
469      `CPL `A, pc, 1
470    | (true,false,true,true),(false,false,true,true) ->
471      `CPL `C, pc, 1
472    | (true,false,true,true),(false,false,true,false) ->
473      let pc,b1 = next pc in
474      `CPL (`BIT b1), pc, 1
475    | (true,true,false,true),(false,true,false,false) ->
476      `DA `A, pc, 1
477    | (false,false,false,true),(false,true,false,false) ->
478      `DEC `A, pc, 1
479    | (false,false,false,true),(true,r1,r2,r3) ->
480      `DEC (`REG(r1,r2,r3)), pc, 1
481    | (false,false,false,true),(false,true,false,true) ->
482      let pc,b1 = next pc in
483      `DEC (`DIRECT b1), pc, 1
484    | (false,false,false,true),(false,true,true,i1) ->
485      `DEC (`INDIRECT i1), pc, 1
486    | (true,false,false,false),(false,true,false,false) ->
487      `DIV (`A, `B), pc, 4
488    | (true,true,false,true),(true,r1,r2,r3) ->
489      let pc,b1 = next pc in
490      `DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2
491    | (true,true,false,true),(false,true,false,true) ->
492      let pc,b1 = next pc in
493      let pc,b2 = next pc in
494      `DJNZ (`DIRECT b1, `REL b2), pc, 2
495    | (false,false,false,false),(false,true,false,false) ->
496      `INC `A, pc, 1
497    | (false,false,false,false),(true,r1,r2,r3) ->
498      `INC (`REG(r1,r2,r3)), pc, 1
499    | (false,false,false,false),(false,true,false,true) ->
500      let pc,b1 = next pc in
501      `INC (`DIRECT b1), pc, 1
502    | (false,false,false,false),(false,true,true,i1) ->
503      `INC (`INDIRECT i1), pc, 1
504    | (true,false,true,false),(false,false,true,true) ->
505      `INC `DPTR, pc, 2
506    | (false,false,true,false),(false,false,false,false) ->
507      let pc,b1 = next pc in
508      let pc,b2 = next pc in
509      `JB (`BIT b1, `REL b2), pc, 2
510    | (false,false,false,true),(false,false,false,false) ->
511      let pc,b1 = next pc in
512      let pc,b2 = next pc in
513      `JBC (`BIT b1, `REL b2), pc, 2
514    | (false,true,false,false),(false,false,false,false) ->
515      let pc,b1 = next pc in
516      `JC (`REL b1), pc, 2
517    | (false,true,true,true),(false,false,true,true) ->
518      `JMP `IND_DPTR, pc, 2
519    | (false,false,true,true),(false,false,false,false) ->
520      let pc,b1 = next pc in
521      let pc,b2 = next pc in
522      `JNB (`BIT b1, `REL b2), pc, 2
523    | (false,true,false,true),(false,false,false,false) ->
524      let pc,b1 = next pc in
525      `JNC (`REL b1), pc, 2
526    | (false,true,true,true),(false,false,false,false) ->
527      let pc,b1 = next pc in
528      `JNZ (`REL b1), pc, 2
529    | (false,true,true,false),(false,false,false,false) ->
530      let pc,b1 = next pc in
531      `JZ (`REL b1), pc, 2
532    | (false,false,false,true),(false,false,true,false) ->
533      let pc,b1 = next pc in
534      let pc,b2 = next pc in
535      `LCALL (`ADDR16 (mk_word b1 b2)), pc, 2
536    | (false,false,false,false),(false,false,true,false) ->
537      let pc,b1 = next pc in
538      let pc,b2 = next pc in
539      `LJMP (`ADDR16 (mk_word b1 b2)), pc, 2
540   | (true,true,true,false),(true,r1,r2,r3) ->
541         `MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1
542   | (true,true,true,false),(false,true,false,true) ->
543       let pc,b1 = next pc in
544         `MOV (`U1 (`A, `DIRECT b1)), pc, 1
545   | (true,true,true,false),(false,true,true,i1) ->
546         `MOV (`U1 (`A, `INDIRECT i1)), pc, 1
547   | (false,true,true,true),(false,true,false,false) ->
548       let pc,b1 = next pc in
549         `MOV (`U1 (`A, `DATA b1)), pc, 1
550   | (true,true,true,true),(true,r1,r2,r3) ->
551         `MOV (`U2 (`REG(r1,r2,r3), `A)), pc, 1
552   | (true,false,true,false),(true,r1,r2,r3) ->
553       let pc,b1 = next pc in
554         `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))), pc, 2
555   | (false,true,true,true),(true,r1,r2,r3) ->
556       let pc,b1 = next pc in
557         `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))), pc, 1
558   | (true,true,true,true),(false,true,false,true) ->
559       let pc,b1 = next pc in
560         `MOV (`U3 (`DIRECT b1, `A)), pc, 1
561   | (true,false,false,false),(true,r1,r2,r3) ->
562       let pc,b1 = next pc in
563         `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))), pc, 2
564   | (true,false,false,false),(false,true,false,true) ->
565       let pc,b1 = next pc in
566       let pc,b2 = next pc in
567         `MOV (`U3 (`DIRECT b1, `DIRECT b2)), pc, 2
568   | (true,false,false,false),(false,true,true,i1) ->
569       let pc,b1 = next pc in
570         `MOV (`U3 (`DIRECT b1, `INDIRECT i1)), pc, 2
571   | (false,true,true,true),(false,true,false,true) ->
572       let pc,b1 = next pc in
573       let pc,b2 = next pc in
574         `MOV (`U3 (`DIRECT b1, `DATA b2)), pc, 3
575   | (true,true,true,true),(false,true,true,i1) ->
576         `MOV (`U2 (`INDIRECT i1, `A)), pc, 1
577   | (true,false,true,false),(false,true,true,i1) ->
578       let pc,b1 = next pc in
579         `MOV (`U2 (`INDIRECT i1, `DIRECT b1)), pc, 2
580   | (false,true,true,true),(false,true,true,i1) ->
581       let pc,b1 = next pc in
582         `MOV (`U2 (`INDIRECT i1, `DATA b1)), pc, 1
583   | (true,false,true,false),(false,false,true,false) ->
584       let pc,b1 = next pc in
585         `MOV (`U5 (`C, `BIT b1)), pc, 1
586   | (true,false,false,true),(false,false,true,false) ->
587       let pc,b1 = next pc in
588         `MOV (`U6 (`BIT b1, `C)), pc, 2
589   | (true,false,false,true),(false,false,false,false) ->
590       let pc,b1 = next pc in
591       let pc,b2 = next pc in
592         `MOV (`U4 (`DPTR, `DATA16(mk_word b1 b2))), pc, 2
593   | (true,false,false,true),(false,false,true,true) ->
594         `MOVC (`A, `A_DPTR), pc, 2
595   | (true,false,false,false),(false,false,true,true) ->
596         `MOVC (`A, `A_PC), pc, 2
597   | (true,true,true,false),(false,false,true,i1) ->
598         `MOVX (`U1 (`A, `EXT_INDIRECT i1)), pc, 2
599   | (true,true,true,false),(false,false,false,false) ->
600         `MOVX (`U1 (`A, `EXT_IND_DPTR)), pc, 2
601   | (true,true,true,true),(false,false,true,i1) ->
602         `MOVX (`U2 (`EXT_INDIRECT i1, `A)), pc, 2
603   | (true,true,true,true),(false,false,false,false) ->
604         `MOVX (`U2 (`EXT_IND_DPTR, `A)), pc, 2
605   | (true,false,true,false),(false,true,false,false) ->
606         `MUL(`A, `B), pc, 4
607   | (false,false,false,false),(false,false,false,false) ->
608         `NOP, pc, 1
609   | (false,true,false,false),(true,r1,r2,r3) ->
610         `ORL (`U1(`A, `REG(r1,r2,r3))), pc, 1
611   | (false,true,false,false),(false,true,false,true) ->
612       let pc,b1 = next pc in
613         `ORL (`U1(`A, `DIRECT b1)), pc, 1
614   | (false,true,false,false),(false,true,true,i1) ->
615         `ORL (`U1(`A, `INDIRECT i1)), pc, 1
616   | (false,true,false,false),(false,true,false,false) ->
617       let pc,b1 = next pc in
618         `ORL (`U1(`A, `DATA b1)), pc, 1
619   | (false,true,false,false),(false,false,true,false) ->
620       let pc,b1 = next pc in
621         `ORL (`U2(`DIRECT b1, `A)), pc, 1
622   | (false,true,false,false),(false,false,true,true) ->
623       let pc,b1 = next pc in
624       let pc,b2 = next pc in
625         `ORL (`U2 (`DIRECT b1, `DATA b2)), pc, 2
626   | (false,true,true,true),(false,false,true,false) ->
627       let pc,b1 = next pc in
628         `ORL (`U3 (`C, `BIT b1)), pc, 2
629   | (true,false,true,false),(false,false,false,false) ->
630       let pc,b1 = next pc in
631         `ORL (`U3 (`C, `NBIT b1)), pc, 2
632   | (true,true,false,true),(false,false,false,false) ->
633       let pc,b1 = next pc in
634         `POP (`DIRECT b1), pc, 2
635   | (true,true,false,false),(false,false,false,false) ->
636       let pc,b1 = next pc in
637         `PUSH (`DIRECT b1), pc, 2
638   | (false,false,true,false),(false,false,true,false) ->
639         `RET, pc, 2
640   | (false,false,true,true),(false,false,true,false) ->
641         `RETI, pc, 2
642   | (false,false,true,false),(false,false,true,true) ->
643         `RL `A, pc, 1
644   | (false,false,true,true),(false,false,true,true) ->
645         `RLC `A, pc, 1
646   | (false,false,false,false),(false,false,true,true) ->
647         `RR `A, pc, 1
648   | (false,false,false,true),(false,false,true,true) ->
649         `RRC `A, pc, 1
650   | (true,true,false,true),(false,false,true,true) ->
651         `SETB `C, pc, 1
652   | (true,true,false,true),(false,false,true,false) ->
653       let pc,b1 = next pc in
654         `SETB (`BIT b1), pc, 1
655   | (true,false,false,false),(false,false,false,false) ->
656       let pc,b1 = next pc in
657         `SJMP (`REL b1), pc, 2
658   | (true,false,false,true),(true,r1,r2,r3) ->
659       `SUBB (`A, `REG(r1,r2,r3)), pc, 1
660   | (true,false,false,true),(false,true,false,true) ->
661       let pc,b1 = next pc in
662         `SUBB (`A, `DIRECT b1), pc, 1
663   | (true,false,false,true),(false,true,true,i1) ->
664         `SUBB (`A, `INDIRECT i1), pc, 1
665   | (true,false,false,true),(false,true,false,false) ->
666       let pc,b1 = next pc in
667         `SUBB (`A, `DATA b1), pc, 1
668   | (true,true,false,false),(false,true,false,false) ->
669         `SWAP `A, pc, 1
670   | (true,true,false,false),(true,r1,r2,r3) ->
671         `XCH (`A, `REG(r1,r2,r3)), pc, 1
672   | (true,true,false,false),(false,true,false,true) ->
673       let pc,b1 = next pc in
674         `XCH (`A, `DIRECT b1), pc, 1
675   | (true,true,false,false),(false,true,true,i1) ->
676         `XCH (`A, `INDIRECT i1), pc, 1
677   | (true,true,false,true),(false,true,true,i1) ->
678         `XCHD(`A, `INDIRECT i1), pc, 1
679   | (false,true,true,false),(true,r1,r2,r3) ->
680         `XRL(`U1(`A, `REG(r1,r2,r3))), pc, 1
681   | (false,true,true,false),(false,true,false,true) ->
682       let pc,b1 = next pc in
683         `XRL(`U1(`A, `DIRECT b1)), pc, 1
684   | (false,true,true,false),(false,true,true,i1) ->
685         `XRL(`U1(`A, `INDIRECT i1)), pc, 1
686   | (false,true,true,false),(false,true,false,false) ->
687       let pc,b1 = next pc in
688         `XRL(`U1(`A, `DATA b1)), pc, 1
689   | (false,true,true,false),(false,false,true,false) ->
690       let pc,b1 = next pc in
691         `XRL(`U2(`DIRECT b1, `A)), pc, 1
692   | (false,true,true,false),(false,false,true,true) ->
693       let pc,b1 = next pc in
694       let pc,b2 = next pc in
695         `XRL(`U2(`DIRECT b1, `DATA b2)), pc, 2
696   | (true,false,true,false),(false,true,false,true) ->
697       (* undefined opcode *) assert false
698;;
699
700let assembly1 =
701 function
702    `ACALL (`ADDR11 w) ->
703      let (a10,a9,a8,b1) = from_word11 w in
704        [mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
705  | `ADD (`A,`REG (r1,r2,r3)) ->
706     [mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
707  | `ADD (`A, `DIRECT b1) ->
708     [mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
709  | `ADD (`A, `INDIRECT i1) ->
710     [mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
711  | `ADD (`A, `DATA b1) ->
712     [mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
713  | `ADDC (`A, `REG(r1,r2,r3)) ->
714     [mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
715  | `ADDC (`A, `DIRECT b1) ->
716     [mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
717  | `ADDC (`A,`INDIRECT i1) ->
718     [mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
719  | `ADDC (`A,`DATA b1) ->
720     [mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
721  | `AJMP (`ADDR11 w) ->
722     let (a10,a9,a8,b1) = from_word11 w in
723       [mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true)); b1]
724  | `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
725     [mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
726  | `ANL (`U1 (`A, `DIRECT b1)) ->
727     [mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
728  | `ANL (`U1 (`A, `INDIRECT i1)) ->
729     [mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
730  | `ANL (`U1 (`A, `DATA b1)) ->
731     [mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
732  | `ANL (`U2 (`DIRECT b1,`A)) ->
733     [mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
734  | `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
735     [mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
736  | `ANL (`U3 (`C,`BIT b1)) ->
737     [mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
738  | `ANL (`U3 (`C,`NBIT b1)) ->
739    [mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
740  | `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
741    [mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
742  | `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
743    [mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
744  | `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
745    [mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
746  | `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
747    [mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
748  | `CLR `A ->
749    [mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
750  | `CLR `C ->
751    [mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
752  | `CLR (`BIT b1) ->
753    [mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
754  | `CPL `A ->
755    [mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
756  | `CPL `C ->
757    [mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
758  | `CPL (`BIT b1) ->
759    [mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
760  | `DA `A ->
761    [mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
762  | `DEC `A ->
763    [mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
764  | `DEC (`REG(r1,r2,r3)) ->
765    [mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
766  | `DEC (`DIRECT b1) ->
767    [mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
768  | `DEC (`INDIRECT i1) ->
769    [mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
770  | `DIV (`A, `B) ->
771    [mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
772  | `DJNZ (`REG(r1,r2,r3), `REL b1) ->
773    [mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
774  | `DJNZ (`DIRECT b1, `REL b2) ->
775    [mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
776  | `INC `A ->
777    [mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
778  | `INC (`REG(r1,r2,r3)) ->
779    [mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
780  | `INC (`DIRECT b1) ->
781    [mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
782  | `INC (`INDIRECT i1) ->
783    [mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
784  | `INC `DPTR ->
785    [mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
786  | `JB (`BIT b1, `REL b2) ->
787    [mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
788  | `JBC (`BIT b1, `REL b2) ->
789    [mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
790  | `JC (`REL b1) ->
791    [mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
792  | `JMP `IND_DPTR ->
793    [mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
794  | `JNB (`BIT b1, `REL b2) ->
795    [mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
796  | `JNC (`REL b1) ->
797    [mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
798  | `JNZ (`REL b1) ->
799    [mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
800  | `JZ (`REL b1) ->
801    [mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
802  | `LCALL (`ADDR16 w) ->
803      let (b1,b2) = from_word w in
804        [mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
805  | `LJMP (`ADDR16 w) ->
806      let (b1,b2) = from_word w in
807        [mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
808  | `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
809    [mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
810  | `MOV (`U1 (`A, `DIRECT b1)) ->
811    [mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
812  | `MOV (`U1 (`A, `INDIRECT i1)) ->
813    [mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
814  | `MOV (`U1 (`A, `DATA b1)) ->
815    [mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
816  | `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
817    [mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
818  | `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
819    [mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
820  | `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
821    [mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
822  | `MOV (`U3 (`DIRECT b1, `A)) ->
823    [mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
824  | `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
825    [mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
826  | `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
827    [mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
828  | `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
829    [mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
830  | `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
831    [mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
832  | `MOV (`U2 (`INDIRECT i1, `A)) ->
833    [mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
834  | `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
835    [mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
836  | `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
837    [mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
838  | `MOV (`U5 (`C, `BIT b1)) ->
839    [mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
840  | `MOV (`U6 (`BIT b1, `C)) ->
841    [mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
842  | `MOV (`U4 (`DPTR, `DATA16 w)) ->
843    let (b1,b2) = from_word w in
844      [mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
845  | `MOVC (`A, `A_DPTR) ->
846    [mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
847  | `MOVC (`A, `A_PC) ->
848    [mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
849  | `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
850    [mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
851  | `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
852    [mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
853  | `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
854    [mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
855  | `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
856    [mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
857  | `MUL(`A, `B) ->
858    [mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
859  | `NOP ->
860    [mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
861  | `ORL (`U1(`A, `REG(r1,r2,r3))) ->
862    [mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
863  | `ORL (`U1(`A, `DIRECT b1)) ->
864    [mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
865  | `ORL (`U1(`A, `INDIRECT i1)) ->
866    [mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
867  | `ORL (`U1(`A, `DATA b1)) ->
868    [mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
869  | `ORL (`U2(`DIRECT b1, `A)) ->
870    [mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
871  | `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
872    [mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
873  | `ORL (`U3 (`C, `BIT b1)) ->
874    [mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
875  | `ORL (`U3 (`C, `NBIT b1)) ->
876    [mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
877  | `POP (`DIRECT b1) ->
878    [mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
879  | `PUSH (`DIRECT b1) ->
880    [mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
881  | `RET ->
882    [mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
883  | `RETI ->
884    [mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
885  | `RL `A ->
886    [mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
887  | `RLC `A ->
888    [mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
889  | `RR `A ->
890    [mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
891  | `RRC `A ->
892    [mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
893  | `SETB `C ->
894    [mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
895  | `SETB (`BIT b1) ->
896    [mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
897  | `SJMP (`REL b1) ->
898    [mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
899  | `SUBB (`A, `REG(r1,r2,r3)) ->
900    [mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
901  | `SUBB (`A, `DIRECT b1) ->
902    [mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
903  | `SUBB (`A, `INDIRECT i1) ->
904    [mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
905  | `SUBB (`A, `DATA b1) ->
906    [mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
907  | `SWAP `A ->
908    [mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
909  | `XCH (`A, `REG(r1,r2,r3)) ->
910    [mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
911  | `XCH (`A, `DIRECT b1) ->
912    [mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
913  | `XCH (`A, `INDIRECT i1) ->
914    [mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
915  | `XCHD(`A, `INDIRECT i1) ->
916    [mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
917  | `XRL(`U1(`A, `REG(r1,r2,r3))) ->
918    [mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
919  | `XRL(`U1(`A, `DIRECT b1)) ->
920    [mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
921  | `XRL(`U1(`A, `INDIRECT i1)) ->
922    [mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
923  | `XRL(`U1(`A, `DATA b1)) ->
924    [mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
925  | `XRL(`U2(`DIRECT b1, `A)) ->
926    [mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
927  | `XRL(`U2(`DIRECT b1, `DATA b2)) ->
928    [mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
929;;
930
931let load_code_memory = MiscPottier.foldi (fun i mem v -> Physical.WordMap.add (vect_of_int i `Sixteen) v mem) Physical.WordMap.empty
932
933let load_mem mem status = { status with code_memory = mem }
934let load l = load_mem (load_code_memory l)
935
936let assembly_jump addr_of =
937 function
938    `JC a1 -> `JC (addr_of a1)
939  | `JNC a1 -> `JNC (addr_of a1)
940  | `JB (a1,a2) -> `JB (a1,addr_of a2)
941  | `JNB (a1,a2) -> `JNB (a1,addr_of a2)
942  | `JBC (a1,a2) -> `JBC (a1,addr_of a2)
943  | `JZ a1 -> `JZ (addr_of a1)
944  | `JNZ a1 -> `JNZ (addr_of a1)
945  | `CJNE (a1,a2) -> `CJNE (a1,addr_of a2)
946  | `DJNZ (a1,a2) -> `DJNZ (a1,addr_of a2)
947;;
948
949let assembly p =
950 let datalabels,_ =
951  List.fold_left
952   (fun (datalabels,addr) (name,size) ->
953     let addr16 = vect_of_int addr `Sixteen in
954      StringTools.Map.add name addr16 datalabels, addr+size
955   ) (StringTools.Map.empty,0) p.ASM.ppreamble
956 in
957 let pc,exit_addr,labels,inds,incs,costs =
958  List.fold_left
959   (fun (pc,exit_addr,labels,inds,incs,costs) i ->
960     match i with
961        `Label s when s = p.ASM.pexit_label -> pc, pc, StringTools.Map.add s pc labels, inds, incs, costs
962      | `Label s -> pc, exit_addr, StringTools.Map.add s pc labels, inds, incs, costs
963      | `Cost s -> pc, exit_addr, labels, inds, incs, BitVectors.WordMap.add pc s costs
964                        | `Index i -> pc, exit_addr, labels, BitVectors.WordMap.add pc i inds, incs, costs
965      | `Inc i -> pc, exit_addr, labels, inds, BitVectors.WordMap.add pc i incs, costs
966      | `Mov (_,_) -> (snd (half_add pc (vect_of_int 1 `Sixteen))), exit_addr, labels, inds, incs, costs
967      | `Jmp _ 
968      | `Call _ -> (snd (half_add pc (BitVectors.vect_of_int 3 `Sixteen))), exit_addr, labels, inds, incs, costs
969      (*CSC: very stupid: always expand to worst opcode *)
970      | `WithLabel i ->
971        let fake_addr _ = `REL (zero `Eight) in
972        let fake_jump = assembly_jump fake_addr i in
973        let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
974        assert (fake_jump = i');
975        let pc' = snd (half_add pc' (vect_of_int 5 `Sixteen)) in
976          (snd (half_add pc pc'), exit_addr, labels, inds, incs, costs)
977      | #instruction as i ->
978        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
979         assert (i = i');
980         (snd (half_add pc pc'),exit_addr,labels, inds, incs, costs)
981   )
982    (BitVectors.zero `Sixteen,BitVectors.zero `Sixteen,
983     StringTools.Map.empty, BitVectors.WordMap.empty, BitVectors.WordMap.empty,
984                 BitVectors.WordMap.empty) p.ASM.pcode
985 in
986 let code =
987  List.flatten (List.map
988     (function
989        `Label _
990      | `Cost _
991                        | `Index _
992                        | `Inc _ -> []
993      | `WithLabel i ->
994         (* We need to expand a conditional jump to a label to a machine language
995            conditional jump.  Suppose we have:
996              JC label
997            This should be expanded to:
998              JC 2         -- size of a short jump
999              SJMP 3       -- size of a long jump
1000              LJMP offset  -- offset = position of label in code
1001            And, for ever label appearing after the location of the jump in code
1002            memory, we must increment by 5, as we added two new instructions. *)
1003        let to_ljmp = `REL (vect_of_int 2 `Eight) in
1004        let offset = 5 in
1005         let jmp_address, translated_jump =
1006           match i with
1007             `JC (`Label a) ->
1008               let address = StringTools.Map.find a labels in
1009               let reconstructed = `JC to_ljmp in
1010                 address, reconstructed
1011           | `JNC (`Label a) ->
1012               let address = StringTools.Map.find a labels in
1013               let reconstructed = `JNC to_ljmp in
1014                 address, reconstructed
1015           | `JB (b, `Label a) ->
1016               let address = StringTools.Map.find a labels in
1017               let reconstructed = `JB (b, to_ljmp) in
1018                 address, reconstructed
1019           | `JNB (b, `Label a) ->
1020               let address = StringTools.Map.find a labels in
1021               let reconstructed = `JNB (b, to_ljmp) in
1022                 address, reconstructed
1023           | `JBC (b, `Label a) ->
1024               let address = StringTools.Map.find a labels in
1025               let reconstructed = `JBC (b, to_ljmp) in
1026                 address, reconstructed
1027           | `JZ (`Label a) ->
1028               let address = StringTools.Map.find a labels in
1029               let reconstructed = `JZ (to_ljmp) in
1030                 address, reconstructed
1031           | `JNZ (`Label a) ->
1032               let address = StringTools.Map.find a labels in
1033               let reconstructed = `JNZ (to_ljmp) in
1034                 address, reconstructed
1035           | `CJNE (args, `Label a) ->
1036               let address = StringTools.Map.find a labels in
1037               let reconstructed = `CJNE (args, to_ljmp) in
1038                 address, reconstructed
1039           | `DJNZ (args, `Label a) ->
1040               let address = StringTools.Map.find a labels in
1041               let reconstructed = `DJNZ (args, to_ljmp) in
1042                 address, reconstructed
1043         in
1044           let sjmp, jmp = `SJMP (`REL (vect_of_int 3 `Eight)), `LJMP (`ADDR16 jmp_address) in
1045           let translation = [ translated_jump; sjmp; jmp ] in
1046             List.flatten (List.map assembly1 translation)
1047      | `Mov (`DPTR,s) ->
1048          let addrr16 = StringTools.Map.find s datalabels in
1049           assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
1050      | `Jmp s ->
1051          let pc_offset = StringTools.Map.find s labels in
1052            assembly1 (`LJMP (`ADDR16 pc_offset))
1053      | `Call s ->
1054          let pc_offset = StringTools.Map.find s labels in
1055            assembly1 (`LCALL (`ADDR16 pc_offset ))
1056      | #instruction as i -> assembly1 i) p.ASM.pcode) in
1057 { ASM.code = code ; ASM.inds = inds; ASM.incs = incs; ASM.cost_labels = costs ;
1058   ASM.exit_addr = exit_addr ; ASM.has_main = p.ASM.phas_main }
1059;;
1060
1061let set_register status v reg =
1062  let addr = get_address_of_register status reg in
1063    { status with low_internal_ram =
1064        Byte7Map.add addr v status.low_internal_ram }
1065;;
1066
1067let get_arg_8 status from_latch = 
1068 function
1069    `DIRECT addr ->
1070       let n0, n1 = from_byte addr in
1071       (match from_nibble n0 with
1072          (false,r1,r2,r3) ->
1073            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
1074        | _ -> get_sfr status addr from_latch)
1075  | `INDIRECT b ->
1076       let (b1, b2) = from_byte (get_register status (false,false,b)) in
1077         (match (from_nibble b1, b2) with 
1078           (false,r1,r2,r3),b2 ->
1079             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
1080         | (true,r1,r2,r3),b2 ->
1081             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
1082  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
1083  | `A -> status.acc
1084  | `B -> status.b
1085  | `DATA b -> b
1086  | `A_DPTR ->
1087       let dpr = mk_word status.dph status.dpl in
1088       (* CSC: what is the right behaviour in case of overflow?
1089          assert false for now. Try to understand what DEC really does *)
1090       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
1091         Physical.WordMap.find addr status.external_ram
1092  | `A_PC ->
1093       (* CSC: what is the right behaviour in case of overflow?
1094          assert false for now *)
1095       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
1096         Physical.WordMap.find addr status.external_ram
1097  | `EXT_INDIRECT b ->
1098         let addr = get_register status (false,false,b) in
1099           Physical.WordMap.find (mk_word (zero `Eight) addr) status.external_ram
1100  | `EXT_IND_DPTR ->
1101       let dpr = mk_word status.dph status.dpl in
1102         Physical.WordMap.find dpr status.external_ram
1103;;
1104
1105let get_arg_16 _status = function `DATA16 w -> w
1106
1107let get_arg_1 status from_latch =
1108  function
1109    `BIT addr
1110  | `NBIT addr as x ->
1111     let n1, n2 = from_byte addr in
1112     let res =
1113      (match from_nibble n1 with
1114         (false,r1,r2,r3) ->
1115           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1116           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1117             get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1118        | (true,r1,r2,r3) ->
1119            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1120            let div = addr / 8 in
1121            let rem = addr mod 8 in
1122              get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1123    in (match x with `NBIT _ -> not res | _ -> res)
1124  | `C -> get_cy_flag status
1125
1126let set_arg_1 status v =
1127  function
1128    `BIT addr ->
1129      let n1, n2 = from_byte addr in
1130      (match from_nibble n1 with
1131         (false,r1,r2,r3) ->
1132           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1133           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1134           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1135             { status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1136      | (true,r1,r2,r3) ->
1137            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1138            let div = addr / 8 in
1139            let rem = addr mod 8 in
1140            let addr' = vect_of_int ((div * 8) + 128) `Eight in
1141            let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1142            let sfr' = set_bit sfr rem v in
1143              set_sfr status addr' sfr')
1144    | `C ->
1145       let (n1,n2) = from_byte status.psw in
1146       let (_,b2,b3,b4) = from_nibble n1 in
1147         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1148
1149let set_arg_8 status v =
1150  function
1151  `DIRECT addr ->
1152    let (b1, b2) = from_byte addr in
1153    (match from_nibble b1 with
1154        (false,r1,r2,r3) ->
1155          { status with low_internal_ram =
1156              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1157      | _ -> set_sfr status addr v)
1158    | `INDIRECT b ->
1159      let (b1, b2) = from_byte (get_register status (false,false,b)) in
1160      (match (from_nibble b1, b2) with 
1161          (false,r1,r2,r3),n1 ->
1162            { status with low_internal_ram =
1163                Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1164        | (true,r1,r2,r3),n1 ->
1165          { status with high_internal_ram =
1166              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1167    | `REG (b1,b2,b3) ->
1168      set_register status v (b1,b2,b3)
1169    | `A -> { status with acc = v }
1170    | `B -> { status with b = v }
1171    | `EXT_IND_DPTR ->
1172      let dpr = mk_word status.dph status.dpl in
1173      { status with external_ram =
1174          Physical.WordMap.add dpr v status.external_ram }
1175    | `EXT_INDIRECT b ->
1176      let addr = get_register status (false,false,b) in
1177      { status with external_ram =
1178          Physical.WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1179;;
1180
1181let set_arg_16 status wrd =
1182  function
1183  `DPTR ->
1184    let (dh, dl) = from_word wrd in
1185    { status with dph = dh; dpl = dl }
1186     
1187let set_flags status c ac ov =
1188  { status with psw =
1189      let bu,bl = from_byte status.psw in
1190      let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1191      let ac = match ac with None -> oac | Some v -> v in
1192      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1193  }
1194;;
1195
1196let xor b1 b2 =
1197  if b1 = true && b2 = true then
1198    false
1199  else if b1 = false && b2 = false then
1200    false
1201  else true
1202;;
1203
1204let read_at_sp status =
1205  let n1,n2 = from_byte status.sp in
1206  let m,r1,r2,r3 = from_nibble n1 in
1207  Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1208    (if m then status.low_internal_ram else status.high_internal_ram)
1209;;
1210
1211let write_at_sp status v =
1212  let n1,n2 = from_byte status.sp in
1213  match from_nibble n1 with
1214      true,r1,r2,r3 ->
1215        let memory =
1216          Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1217        in
1218        { status with low_internal_ram = memory }
1219    | false,r1,r2,r3 ->
1220      let memory =
1221        Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1222      in
1223      { status with high_internal_ram = memory }
1224;;
1225
1226let timer0 status b1 b2 ticks =
1227  let b = get_bit status.tcon 4 in
1228          (* Timer0 first *)
1229  (match b1,b2 with
1230      true,true ->
1231              (* Archaic 13 bit mode. *)
1232        if b then
1233          let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1234          let res = int_of_vect res in
1235          if res > 31 then
1236            let res = res mod 32 in
1237            let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1238            if ov' then
1239              let b = set_bit status.tcon 7 true in
1240              { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1241            else
1242              { status with th0 = res'; tl0 = vect_of_int res `Eight }
1243          else
1244            { status with tl0 = vect_of_int res `Eight }
1245        else
1246          status
1247    | false,false ->
1248              (* 8 bit split timer mode. *)
1249      let status = 
1250        (if b then
1251            let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1252            if ov then
1253              let b = set_bit status.tcon 5 true in
1254              { status with tcon = b; tl0 = res }
1255            else
1256              { status with tl0 = res }
1257         else
1258            status)
1259      in
1260      if get_bit status.tcon 6 then
1261        let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1262        if ov then
1263          let b = set_bit status.tcon 7 true in
1264          { status with tcon = b; th0 = res }
1265        else
1266          { status with th0 = res }
1267      else
1268        status
1269    | false,true ->
1270             (* 16 bit timer mode. *)
1271      if b then
1272        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1273                if ov then
1274                  let b = set_bit status.tcon 5 true in
1275                  let new_th0,new_tl0 = from_word res in
1276                  { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1277                else
1278                  let new_th0,new_tl0 = from_word res in
1279                  { status with th0 = new_th0; tl0 = new_tl0 }
1280      else
1281        status
1282    | true,false ->
1283              (* 8 bit single timer mode. *)
1284      if b then
1285        let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1286        if ov then
1287          let b = set_bit status.tcon 5 true in
1288          { status with tcon = b; tl0 = status.th0; }
1289        else
1290          { status with tl0 = res }
1291      else
1292        status)
1293   
1294let timer1 status b3 b4 ticks =
1295  let b = get_bit status.tcon 4 in
1296  (match b3,b4 with
1297      true,true ->
1298        (* Archaic 13 bit mode. *)
1299        if b then
1300          let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1301          let res = int_of_vect res in
1302          if res > 31 then
1303            let res = res mod 32 in
1304            let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1305            if ov' then
1306              let b = set_bit status.tcon 7 true in
1307              { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1308            else
1309              { status with th1 = res'; tl0 = vect_of_int res `Eight }
1310          else
1311            { status with tl1 = vect_of_int res `Eight }
1312        else
1313          status
1314    | false,false ->
1315              (* 8 bit split timer mode. *)
1316      let status = 
1317        (if b then
1318            let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1319            if ov then
1320              let b = set_bit status.tcon 5 true in
1321                        { status with tcon = b; tl1 = res }
1322            else
1323              { status with tl1 = res }
1324         else
1325            status)
1326      in
1327      if get_bit status.tcon 6 then
1328        let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1329        if ov then
1330          let b = set_bit status.tcon 7 true in
1331          { status with tcon = b; th1 = res }
1332        else
1333          { status with th1 = res }
1334      else
1335        status
1336    | false,true ->
1337             (* 16 bit timer mode. *)
1338      if b then
1339        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1340        if ov then
1341          let b = set_bit status.tcon 5 true in
1342          let new_th1,new_tl1 = from_word res in
1343          { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1344        else
1345          let new_th1,new_tl1 = from_word res in
1346          { status with th1 = new_th1; tl1 = new_tl1 }
1347      else
1348        status
1349    | true,false ->
1350              (* 8 bit single timer mode. *)
1351      if b then
1352        let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1353        if ov then
1354          let b = set_bit status.tcon 5 true in
1355          { status with tcon = b; tl1 = status.th1; }
1356        else
1357          { status with tl1 = res }
1358      else
1359        status)
1360;;
1361
1362let timers status ticks =
1363  (* DPM: Clock/Timer code follows. *)
1364  match bits_of_byte status.tmod with
1365    | (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1366      let status =
1367        (if g0 then
1368            if get_bit status.p3 2 then
1369              if c0 then
1370                if status.previous_p1_val && not $ get_bit status.p3 4 then
1371                  timer0 status b1 b2 ticks
1372                else
1373                  status
1374              else
1375                timer0 status b1 b2 ticks
1376            else
1377              status
1378         else
1379            timer0 status b1 b2 ticks) in
1380      (* Timer 1 follows. *)
1381      let status =
1382        (if g1 then
1383            if get_bit status.p1 3 then
1384              if c1 then
1385                if status.previous_p3_val && not $ get_bit status.p3 5 then
1386                  timer1 status b3 b4 ticks
1387                else
1388                  status
1389              else
1390                timer1 status b3 b4 ticks
1391            else
1392              status
1393         else
1394            timer1 status b3 b4 ticks) in
1395      (* Timer 2 follows *)
1396      let status =
1397        (let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in
1398          (* Timer2 is enabled *)
1399         if tr2 then
1400            (* Counter/interval mode *)
1401           if ct2 && not cp2 then
1402             let word = mk_word status.th2 status.tl2 in
1403             let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in
1404             if ov then
1405               let new_th2 = status.rcap2h in
1406               let new_tl2 = status.rcap2l in
1407                  (* Overflow flag not set if either of the following flags are set *)
1408               if not rclk && not tclk then
1409                 let b = set_bit status.t2con 7 true in
1410                 { status with t2con = b;
1411                   th2 = new_th2;
1412                   tl2 = new_tl2 }
1413               else
1414                 { status with th2 = new_th2;
1415                   tl2 = new_tl2 }
1416             else
1417                (* Reload also signalled when a 1-0 transition is detected *)
1418               if status.previous_p1_val && not $ get_bit status.p1 1 then
1419                  (* In which case signal reload by setting T2CON.6 *)
1420                 let b = set_bit status.t2con 6 true in
1421                 { status with th2 = status.rcap2h;
1422                   tl2 = status.rcap2l;
1423                   t2con = b }
1424               else
1425                 let new_th2, new_tl2 = from_word res in
1426                 { status with th2 = new_th2;
1427                   tl2 = new_tl2 }
1428            (* Capture mode *)
1429           else if cp2 && exen2 then
1430              (* 1-0 transition detected *)
1431              (* DPM: look at this: is the timer still running throughout? *)
1432             if status.previous_p1_val && not $ get_bit status.p1 1 then
1433               status (* Implement clock here *)
1434             else
1435               status (* Implement clock here *)
1436           else
1437             status
1438           else
1439             status) in status
1440                     
1441;;
1442
1443let serial_port_input status in_cont =
1444      (* Serial port input *)
1445  match in_cont with
1446      Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1447        (let status =
1448           (match line with
1449               `P1 b ->
1450                 if status.clock >= time then
1451                   { status with p1 = b; p1_latch = b; }
1452                 else
1453                   status
1454             | `P3 b ->
1455               if status.clock >= time then
1456                 { status with p3 = b; p3_latch = b; }
1457               else
1458                 status
1459             | `SerialBuff (`Eight b) ->
1460               let sm0 = get_bit status.scon 7 in
1461               let sm1 = get_bit status.scon 6 in
1462               (match (sm0, sm1) with
1463                   (false, false) ->
1464                       (* Mode 0: shift register.  No delay. *)
1465                     if status.clock >= time then
1466                       { status with scon = set_bit status.scon 0 true;
1467                         io   = cont;
1468                         sbuf = b }
1469                     else
1470                       status
1471                 | (false, true) ->
1472                       (* Mode 1: 8-bit UART *)
1473                       (* Explanation: 8 bit asynchronous communication.  There's a delay (epsilon)
1474                          which needs taking care of.  If we're trying to communicate at the same time
1475                          an existing communication is occurring, we assert false (else clause of first
1476                          if). *)
1477                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1478                     if status.clock >= time then
1479                           (* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1480                       if get_bit status.scon 5 then
1481                         assert false (* really: crash! *)
1482                       else
1483                         { status with serial_epsilon_in = Some (epsilon + time);
1484                           serial_v_in       = Some (`Eight b) }
1485                     else
1486                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1487                              None. *)
1488                       let Some e = status.serial_epsilon_in in
1489                       let Some v = status.serial_v_in in
1490                       if status.clock >= e then
1491                         match v with
1492                             `Eight v' ->
1493                               { status with sbuf = v';
1494                                 serial_v_in = None;
1495                                 serial_epsilon_in = None;
1496                                 scon = set_bit status.scon 0 true;
1497                                 io = cont }
1498                           | _ -> assert false (* trying to read in 9 bits instead of 8 *)
1499                       else
1500                         status
1501                   else
1502                     assert false
1503                 | (true, false) | (true, true) ->
1504                   assert false (* only got eight bits on the line when in 9 bit mode *))
1505             | `SerialBuff (`Nine (b,b')) ->
1506               let sm0 = get_bit status.scon 7 in
1507               let sm1 = get_bit status.scon 6 in
1508               match(sm0, sm1) with
1509                   (false, false) | (false, true) -> assert false
1510                 | (true, false)  | (true, true) ->
1511                       (* Modes 2 and 3: 9-bit UART *)
1512                       (* Explanation: 9 bit asynchronous communication.  There's a delay (epsilon)
1513                          which needs taking care of.  If we're trying to communicate at the same time
1514                          an existing communication is occurring, we assert false (else claus of first
1515                          if). *)
1516                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1517                     if status.clock >= time then
1518                           (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1519                       if get_bit status.scon 5 then
1520                         assert false (* really: crash! *)
1521                       else
1522                         { status with serial_epsilon_in = Some (epsilon + time);
1523                           serial_v_in       = Some (`Nine (b, b')) }
1524                     else
1525                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1526                              None. *)
1527                       let Some e = status.serial_epsilon_in in
1528                       let Some v = status.serial_v_in in
1529                       if status.clock >= e then
1530                         match v with
1531                             `Nine (v, v') ->
1532                               let scon' = set_bit status.scon 0 true in
1533                               { status with sbuf = v';
1534                                 serial_v_in = None;
1535                                 serial_epsilon_in = None;
1536                                 scon = set_bit scon' 2 b;
1537                                 io = cont }
1538                           | _ -> assert false (* trying to read in 8 bits instead of 9 *)
1539                       else
1540                         status
1541                   else
1542                     assert false)
1543         in
1544         { status with io = cont })
1545    | _ -> status
1546;;
1547
1548let serial_port_output status out_cont =
1549  (* Serial port output *)
1550  (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1551    serial_v_out = Some (`Eight status.sbuf);
1552    serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1553   match status.serial_epsilon_out with
1554       Some s ->
1555         if status.clock >= s then
1556           match status.serial_k_out with
1557               None -> assert false (* correct? *)
1558             | Some k' -> { status with io   = k';
1559               scon = set_bit status.scon 1 true; }
1560         else
1561           status
1562     | _ -> assert false)
1563;;
1564
1565let external_serial_interrupt status esi =
1566  (* Interrupt enabled *)
1567  if esi then
1568    (* If we're already running, then fine (todo: check for *another* interrupt
1569       and add to a queue, or something? *)
1570    if status.t1i_running then
1571      status
1572    else
1573      (* If we should be running, but aren't... *)
1574      if false then
1575        assert false
1576      else
1577        status
1578  else
1579    status
1580;;
1581
1582let external0_interrupt status e0i =
1583  (* Interrupt enabled *)
1584  if e0i then
1585    (* If we're already running, then fine (todo: check for *another* interrupt
1586       and add to a queue, or something? *)
1587    if status.t1i_running then
1588      status
1589    else
1590      (* If we should be running, but aren't... *)
1591      if false then
1592        assert false
1593      else
1594        status
1595  else
1596    status
1597;;
1598
1599let external1_interrupt status e1i =
1600  (* Interrupt enabled *)
1601  if e1i then
1602    (* If we're already running, then fine (todo: check for *another* interrupt
1603       and add to a queue, or something? *)
1604    if status.t1i_running then
1605      status
1606    else
1607      (* If we should be running, but aren't... *)
1608      if false then
1609        assert false
1610      else
1611        status
1612  else
1613    status
1614;;
1615
1616let timer0_interrupt status t0i =
1617  (* Interrupt enabled *)
1618  if t0i then
1619    (* If we're already running, then fine (todo: check for *another* interrupt
1620       and add to a queue, or something? *)
1621    if status.t1i_running then
1622      status
1623    else
1624      (* If we should be running, but aren't... *)
1625      if false then
1626        assert false
1627      else
1628        status
1629  else
1630    status
1631;;
1632
1633let timer1_interrupt status t1i =
1634  (* Interrupt enabled *)
1635  if t1i then
1636    (* If we're already running, then fine (todo: check for *another* interrupt
1637       and add to a queue, or something? *)
1638    if status.t1i_running then
1639      status
1640    else
1641      (* If we should be running, but aren't... *)
1642      if false then
1643        assert false
1644      else
1645        status
1646  else
1647    status
1648;;
1649
1650let interrupts status =
1651  let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1652  let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1653    (* DPM: are interrupts enabled? *)
1654  if ea then
1655    match (ps,pt1,px1,pt0,px0) with
1656        _ -> assert false
1657  else
1658    status
1659;;
1660
1661let execute1 status =
1662  let instr,pc,ticks = fetch status.code_memory status.pc in
1663  let status = { status with clock = status.clock + ticks; pc = pc } in
1664  let status =
1665    (match instr with
1666        `ADD (`A,d1) ->
1667          let v,c,ac,ov =
1668            add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1669          in
1670          set_flags (set_arg_8 status v `A) c (Some ac) ov
1671      | `ADDC (`A,d1) ->
1672        let v,c,ac,ov =
1673          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1674        in
1675        set_flags (set_arg_8 status v `A) c (Some ac) ov
1676      | `SUBB (`A,d1) ->
1677        let v,c,ac,ov =
1678          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1679        in
1680        set_flags (set_arg_8 status v `A) c (Some ac) ov
1681      | `INC `DPTR ->
1682        let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1683        let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1684        { status with dpl = low_order_byte; dph = high_order_byte }
1685      | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1686        let b = get_arg_8 status true d in
1687        let cry, res = half_add b (vect_of_int 1 `Eight) in
1688        set_arg_8 status res d
1689      | `DEC d ->
1690        let b = get_arg_8 status true d in
1691        let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1692        set_arg_8 status res d
1693      | `MUL (`A,`B) ->
1694        let acc = int_of_vect status.acc in
1695        let b = int_of_vect status.b in
1696        let prod = acc * b in
1697        let ov = prod > 255 in
1698        let l = vect_of_int (prod  mod 256) `Eight in
1699        let h = vect_of_int (prod / 256) `Eight in
1700        let status = { status with acc = l ; b = h } in
1701         (* DPM: Carry flag is always cleared. *)
1702        set_flags status false None ov
1703      | `DIV (`A,`B) ->
1704        let acc = int_of_vect status.acc in
1705        let b = int_of_vect status.b in
1706        if b = 0 then
1707        (* CSC: ACC and B undefined! We leave them as they are. *)
1708          set_flags status false None true
1709        else
1710          let q = vect_of_int (acc / b) `Eight in
1711          let r = vect_of_int (acc mod b) `Eight in
1712          let status = { status with acc = q ; b = r } in
1713          set_flags status false None false
1714      | `DA `A ->
1715        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1716        if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1717          let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1718          let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1719          if int_of_vect acc_upper_nibble > 9 or cy = true then
1720            let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1721            let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1722            set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1723          else
1724            status
1725        else
1726          status
1727      | `ANL (`U1(`A, ag)) ->
1728        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1729        set_arg_8 status and_val `A
1730      | `ANL (`U2((`DIRECT d), ag)) ->
1731        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1732        set_arg_8 status and_val (`DIRECT d)
1733      | `ANL (`U3 (`C, b)) ->
1734        let and_val = get_cy_flag status && get_arg_1 status true b in
1735        set_flags status and_val None (get_ov_flag status)
1736      | `ORL (`U1(`A, ag)) ->
1737        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1738        set_arg_8 status or_val `A
1739      | `ORL (`U2((`DIRECT d), ag)) ->
1740        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1741        set_arg_8 status or_val (`DIRECT d)
1742      | `ORL (`U3 (`C, b)) ->
1743        let or_val = get_cy_flag status || get_arg_1 status true b in
1744        set_flags status or_val None (get_ov_flag status)
1745      | `XRL (`U1(`A, ag)) ->
1746        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1747        set_arg_8 status xor_val `A
1748      | `XRL (`U2((`DIRECT d), ag)) ->
1749        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1750        set_arg_8 status xor_val (`DIRECT d)
1751      | `CLR `A -> set_arg_8 status (zero `Eight) `A
1752      | `CLR `C -> set_arg_1 status false `C
1753      | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1754      | `CPL `A -> { status with acc = complement status.acc }
1755      | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1756      | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1757      | `RL `A -> { status with acc = rotate_left status.acc }
1758      | `RLC `A ->
1759        let old_cy = get_cy_flag status in
1760        let n1, n2 = from_byte status.acc in
1761        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1762        let status = set_arg_1 status b1 `C in
1763        { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1764      | `RR `A -> { status with acc = rotate_right status.acc }
1765      | `RRC `A ->
1766        let old_cy = get_cy_flag status in
1767        let n1, n2 = from_byte status.acc in
1768        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1769        let status = set_arg_1 status b8 `C in
1770        { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1771      | `SWAP `A ->
1772        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1773        { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1774      | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1775      | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1776      | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1777      | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1778      | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1779      | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1780      | `MOVC (`A, `A_DPTR) ->
1781        let big_acc = mk_word (zero `Eight) status.acc in
1782        let dptr = mk_word status.dph status.dpl in
1783        let cry, addr = half_add dptr big_acc in
1784        let lookup = Physical.WordMap.find addr status.code_memory in
1785        { status with acc = lookup }
1786      | `MOVC (`A, `A_PC) ->
1787        let big_acc = mk_word (zero `Eight) status.acc in
1788        (* DPM: Under specified: does the carry from PC incrementation affect the *)
1789        (*      addition of the PC with the DPTR? At the moment, no.              *)
1790        let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1791        let status = { status with pc = inc_pc } in
1792        let cry,addr = half_add inc_pc big_acc in
1793        let lookup = Physical.WordMap.find addr status.code_memory in
1794        { status with acc = lookup }
1795      (* data transfer *)
1796      (* DPM: MOVX currently only implements the *copying* of data! *)
1797      | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1798      | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1799      | `SETB b -> set_arg_1 status true b
1800      | `PUSH a ->
1801       (* DPM: What happens if we overflow? *)
1802        let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1803        let status = { status with sp = new_sp } in
1804        write_at_sp status (get_arg_8 status false a)
1805      | `POP (`DIRECT b) ->
1806        let contents = read_at_sp status in
1807        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1808        let status = { status with sp = new_sp } in
1809        let status = set_arg_8 status contents (`DIRECT b) in
1810        status
1811      | `XCH(`A, arg) ->
1812        let old_arg = get_arg_8 status false arg in
1813        let old_acc = status.acc in
1814        let status = set_arg_8 status old_acc arg in
1815        { status with acc = old_arg }
1816      | `XCHD(`A, i) ->
1817        let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1818        let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1819        let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1820        let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1821        let status = { status with acc = new_acc } in
1822        set_arg_8 status new_reg i
1823      (* program branching *)
1824      | `JC (`REL rel) ->
1825        if get_cy_flag status then
1826          let cry, new_pc = half_add status.pc (sign_extension rel) in
1827          { status with pc = new_pc }
1828        else
1829          status
1830      | `JNC (`REL rel) ->
1831        if not $ get_cy_flag status then
1832          let cry, new_pc = half_add status.pc (sign_extension rel) in
1833          { status with pc = new_pc }
1834        else
1835          status
1836      | `JB (b, (`REL rel)) ->
1837        if get_arg_1 status false b then
1838          let cry, new_pc = half_add status.pc (sign_extension rel) in
1839          { status with pc = new_pc }
1840        else
1841          status
1842      | `JNB (b, (`REL rel)) ->
1843        if not $ get_arg_1 status false b then
1844          let cry, new_pc = half_add status.pc (sign_extension rel) in
1845          { status with pc = new_pc }
1846        else
1847          status
1848      | `JBC (b, (`REL rel)) ->
1849        let status = set_arg_1 status false b in
1850        if get_arg_1 status false b then
1851          let cry, new_pc = half_add status.pc (sign_extension rel) in
1852          { status with pc = new_pc }
1853        else
1854          status
1855      | `RET ->
1856        (* DPM: What happens when we underflow? *)
1857        let high_bits = read_at_sp status in
1858        let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1859        let status = { status with sp = new_sp } in
1860        let low_bits = read_at_sp status in
1861        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1862        let status = { status with sp = new_sp } in
1863        { status with pc = mk_word high_bits low_bits }
1864      | `RETI ->
1865        let high_bits = read_at_sp status in
1866        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1867        let status = { status with sp = new_sp } in
1868        let low_bits = read_at_sp status in
1869        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1870        let status = { status with sp = new_sp } in
1871        { status with pc = mk_word high_bits low_bits }
1872      | `ACALL (`ADDR11 a) ->
1873        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1874        let status = { status with sp = new_sp } in
1875        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1876        let status = write_at_sp status pc_lower_byte in
1877        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1878        let status = { status with sp = new_sp } in
1879        let status = write_at_sp status pc_upper_byte in
1880        let addr = addr16_of_addr11 status.pc a in
1881        { status with pc = addr }
1882      | `LCALL (`ADDR16 addr) ->
1883        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1884        let status = { status with sp = new_sp } in
1885        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1886        let status = write_at_sp status pc_lower_byte in
1887        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1888        let status = { status with sp = new_sp } in
1889        let status = write_at_sp status pc_upper_byte in
1890        { status with pc = addr }
1891      | `AJMP (`ADDR11 a) ->
1892        let addr = addr16_of_addr11 status.pc a in
1893        { status with pc = addr }
1894      | `LJMP (`ADDR16 a) ->
1895        { status with pc = a }
1896      | `SJMP (`REL rel) ->
1897        let cry, new_pc = half_add status.pc (sign_extension rel) in
1898        { status with pc = new_pc }
1899      | `JMP `IND_DPTR ->
1900        let dptr = mk_word status.dph status.dpl in
1901        let big_acc = mk_word (zero `Eight) status.acc in
1902        let cry, jmp_addr = half_add big_acc dptr in
1903        let cry, new_pc = half_add status.pc jmp_addr in
1904        { status with pc = new_pc }
1905      | `JZ (`REL rel) ->
1906        if status.acc = zero `Eight then
1907          let cry, new_pc = half_add status.pc (sign_extension rel) in
1908          { status with pc = new_pc }
1909        else
1910          status
1911      | `JNZ (`REL rel) ->
1912        if status.acc <> zero `Eight then
1913          let cry, new_pc = half_add status.pc (sign_extension rel) in
1914          { status with pc = new_pc }
1915        else
1916          status
1917      | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1918        let new_carry = status.acc < get_arg_8 status false ag in
1919        if get_arg_8 status false ag <> status.acc then
1920          let cry, new_pc = half_add status.pc (sign_extension rel) in
1921          let status = set_flags status new_carry None (get_ov_flag status) in
1922          { status with pc = new_pc;  }
1923        else
1924          set_flags status new_carry None (get_ov_flag status)
1925      | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1926        let new_carry = get_arg_8 status false ag < d in
1927        if get_arg_8 status false ag <> d then
1928          let cry, new_pc = half_add status.pc (sign_extension rel) in
1929          let status = { status with pc = new_pc } in
1930          set_flags status new_carry None (get_ov_flag status)
1931        else
1932          set_flags status new_carry None (get_ov_flag status)
1933      | `DJNZ (ag, (`REL rel)) ->
1934        let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1935        let status = set_arg_8 status new_ag ag in
1936        if new_ag <> zero `Eight then
1937          let cry, new_pc = half_add status.pc (sign_extension rel) in
1938          { status with pc = new_pc }
1939        else
1940          status
1941      | `NOP -> status) in
1942  let status = timers status ticks in
1943  let in_cont, `Out out_cont = status.io in
1944  let status = serial_port_input status in_cont in
1945  let status = serial_port_output status out_cont in
1946  let status = interrupts status in
1947  { status with previous_p1_val = get_bit status.p3 4;
1948    previous_p3_val = get_bit status.p3 5 }
1949;;
1950
1951(*
1952OLD output routine:
1953           (* Serial port output, part one *)
1954           let status =
1955             (match status.expected_out_time with
1956               `At t when status.clock >= t ->
1957                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1958              | _ -> status) in
1959
1960             (if status.expected_out_time = `Now then
1961               if get_bit status.scon 7 then
1962                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1963                   { status with expected_out_time = `At exp_time; io = new_cont }
1964               else
1965                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1966                   { status with expected_out_time = `At exp_time; io = new_cont }               
1967             else
1968               status) in
1969*)
1970
1971let rec execute f s =
1972  let cont =
1973    try f s; true
1974    with Halt -> false
1975  in
1976  if cont then execute f (execute1 s)
1977  else s
1978;;
1979
1980
1981let load_program p =
1982  let st = load p.ASM.code initialize in
1983  { st with exit_addr = p.ASM.exit_addr ; cost_labels = p.ASM.cost_labels }
1984
1985type cost_trace = {
1986        mutable ct_labels : CostLabel.t list;
1987        mutable ct_inds   : CostLabel.const_indexing list;
1988}
1989
1990(* TODO: indexes *)
1991let observe_trace trace st =
1992        let update_ct_labels =
1993          try
1994                        let cost_label = BitVectors.WordMap.find st.pc st.cost_labels in
1995            trace.ct_labels <- cost_label :: trace.ct_labels
1996          with Not_found -> () in
1997        update_ct_labels;
1998  if st.pc = st.exit_addr (* <=> end of program *) then raise Halt else st
1999
2000let result st =
2001  let dpl = st.dpl in
2002  let dpr = st.dph in
2003  let addr i = BitVectors.vect_of_int i `Seven in
2004  let get_ireg i = Physical.Byte7Map.find (addr i) st.low_internal_ram in
2005  let r00 = get_ireg 0 in
2006  let r01 = get_ireg 1 in
2007  let is = [dpl ; dpr ; r00 ; r01] in
2008  let f i = IntValue.Int32.of_int (BitVectors.int_of_vect i) in
2009  IntValue.Int32.merge (List.map f is)
2010
2011let interpret debug p =
2012  Printf.printf "*** 8051 interpret ***\n%!" ;
2013  if p.ASM.has_main then
2014    let st = load_program p in
2015    let trace = {ct_labels = []; ct_inds = []} in
2016    let callback = observe_trace trace in
2017    let st = execute callback st in
2018    let res = result st in
2019    if debug then
2020      Printf.printf "Result = %s\n%!" (IntValue.Int32.to_string res) ;
2021    (res, List.rev trace.ct_labels)
2022  else (IntValue.Int32.zero, [])
Note: See TracBrowser for help on using the repository browser.