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

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

Fixes to debug code to make serial output more clear. CJNE/JNZ is not a
bug with emulator, but with mcu's `normalise hex file' function. Do not
use!

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