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

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

Refactored main emulator loop to improve clarity. Debugging serial I/O
now.

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