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

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

Remaining two timer modes implemented.

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