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

Last change on this file since 1291 was 1291, checked in by tranquil, 9 years ago

Started branch of untrusted compiler with indexed labels

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