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

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

Reworked handling of serial port input, and implemented remaining input modes.

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