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

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

Fixed serial output.

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