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

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

Implemented output onto P1 and P3 lines, implemented a few of the other
timer modes.

File size: 67.4 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
883
884let assembly_jump addr_of =
885 function
886    `JC a1 -> `JC (addr_of a1)
887  | `JNC a1 -> `JNC (addr_of a1)
888  | `JB (a1,a2) -> `JB (a1,addr_of a2)
889  | `JNB (a1,a2) -> `JNB (a1,addr_of a2)
890  | `JBC (a1,a2) -> `JBC (a1,addr_of a2)
891  | `JZ a1 -> `JZ (addr_of a1)
892  | `JNZ a1 -> `JNZ (addr_of a1)
893  | `CJNE (a1,a2) -> `CJNE (a1,addr_of a2)
894  | `DJNZ (a1,a2) -> `DJNZ (a1,addr_of a2)
895;;
896
897let assembly (preamble,l) =
898 let datalabels,_ =
899  List.fold_left
900   (fun (datalabels,addr) (name,size) ->
901     let addr16 = vect_of_int addr `Sixteen in
902      StringMap.add name addr16 datalabels, addr+size
903   ) (StringMap.empty,0) preamble
904 in
905 let pc,labels,costs =
906  List.fold_left
907   (fun (pc,labels,costs) i ->
908     match i with
909        `Label s -> pc, StringMap.add s pc labels, costs
910      | `Cost s -> pc, labels, IntMap.add pc s costs
911      | `Mov (_,_) -> pc, labels, costs
912      | `Jmp _ 
913      | `Call _ -> pc + 3, labels, costs  (*CSC: very stupid: always expand to worst opcode *)
914      | `WithLabel i ->
915          let fake_addr _ = `REL (zero `Eight) in
916          let fake_jump = assembly_jump fake_addr i in
917          let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
918           assert (fake_jump = i');
919           (pc + int_of_vect pc',labels, costs)
920      | #instruction as i ->
921        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
922         assert (i = i');
923         (pc + int_of_vect pc',labels, costs)
924   ) (0,StringMap.empty,IntMap.empty) l
925 in
926  if pc >= 65536 then
927   raise CodeTooLarge
928  else
929      List.flatten (List.map
930         (function
931            `Label _
932          | `Cost _ -> []
933          | `WithLabel i ->
934              let addr_of (`Label s) =
935               let addr = StringMap.find s labels in
936               (* NOT IMPLEMENTED YET; NEEDS SMART ALGORITHM *)
937                assert (addr < 256);
938                `REL (vect_of_int addr `Eight)
939              in
940               assembly1 (assembly_jump addr_of i)
941          | `Mov (`DPTR,s) ->
942              let addrr16 = StringMap.find s datalabels in
943               assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
944          | `Jmp s ->
945              let pc_offset = StringMap.find s labels in
946                assembly1 (`LJMP (`ADDR16 (vect_of_int pc_offset `Sixteen)))
947          | `Call s ->
948              let pc_offset = StringMap.find s labels in
949                assembly1 (`LCALL (`ADDR16 (vect_of_int pc_offset `Sixteen)))
950          | #instruction as i -> assembly1 i) l), costs
951;;
952
953let set_register status v reg =
954  let addr = get_address_of_register status reg in
955    { status with low_internal_ram =
956        Byte7Map.add addr v status.low_internal_ram }
957;;
958
959let get_arg_8 status from_latch = 
960 function
961    `DIRECT addr ->
962       let n0, n1 = from_byte addr in
963       (match from_nibble n0 with
964          (false,r1,r2,r3) ->
965            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
966        | _ -> get_sfr status addr from_latch)
967  | `INDIRECT b ->
968       let (b1, b2) = from_byte (get_register status (false,false,b)) in
969         (match (from_nibble b1, b2) with 
970           (false,r1,r2,r3),b2 ->
971             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
972         | (true,r1,r2,r3),b2 ->
973             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
974  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
975  | `A -> status.acc
976  | `B -> status.b
977  | `DATA b -> b
978  | `A_DPTR ->
979       let dpr = mk_word status.dph status.dpl in
980       (* CSC: what is the right behaviour in case of overflow?
981          assert false for now. Try to understand what DEC really does *)
982       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
983         WordMap.find addr status.external_ram
984  | `A_PC ->
985       (* CSC: what is the right behaviour in case of overflow?
986          assert false for now *)
987       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
988         WordMap.find addr status.external_ram
989  | `EXT_INDIRECT b ->
990         let addr = get_register status (false,false,b) in
991           WordMap.find (mk_word (zero `Eight) addr) status.external_ram
992  | `EXT_IND_DPTR ->
993       let dpr = mk_word status.dph status.dpl in
994         WordMap.find dpr status.external_ram
995;;
996
997let get_arg_16 _status = function `DATA16 w -> w
998
999let get_arg_1 status from_latch =
1000  function
1001    `BIT addr
1002  | `NBIT addr as x ->
1003     let n1, n2 = from_byte addr in
1004     let res =
1005      (match from_nibble n1 with
1006         (false,r1,r2,r3) ->
1007           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1008           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1009             get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1010        | (true,r1,r2,r3) ->
1011            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1012            let div = addr / 8 in
1013            let rem = addr mod 8 in
1014              get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1015    in (match x with `NBIT _ -> not res | _ -> res)
1016  | `C -> get_cy_flag status
1017
1018let set_arg_1 status v =
1019  function
1020    `BIT addr ->
1021      let n1, n2 = from_byte addr in
1022      (match from_nibble n1 with
1023         (false,r1,r2,r3) ->
1024           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1025           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1026           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1027             { status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1028      | (true,r1,r2,r3) ->
1029            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1030            let div = addr / 8 in
1031            let rem = addr mod 8 in
1032            let addr' = vect_of_int ((div * 8) + 128) `Eight in
1033            let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1034            let sfr' = set_bit sfr rem v in
1035              set_sfr status addr' sfr')
1036    | `C ->
1037       let (n1,n2) = from_byte status.psw in
1038       let (_,b2,b3,b4) = from_nibble n1 in
1039         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1040
1041let set_arg_8 status v =
1042 function
1043    `DIRECT addr ->
1044      let (b1, b2) = from_byte addr in
1045      (match from_nibble b1 with
1046         (false,r1,r2,r3) ->
1047           { status with low_internal_ram =
1048              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1049       | _ -> set_sfr status addr v)
1050  | `INDIRECT b ->
1051     let (b1, b2) = from_byte (get_register status (false,false,b)) in
1052     (match (from_nibble b1, b2) with 
1053         (false,r1,r2,r3),n1 ->
1054           { status with low_internal_ram =
1055              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1056       | (true,r1,r2,r3),n1 ->
1057           { status with high_internal_ram =
1058              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1059  | `REG (b1,b2,b3) ->
1060      set_register status v (b1,b2,b3)
1061  | `A -> { status with acc = v }
1062  | `B -> { status with b = v }
1063  | `EXT_IND_DPTR ->
1064      let dpr = mk_word status.dph status.dpl in
1065        { status with external_ram =
1066          WordMap.add dpr v status.external_ram }
1067  | `EXT_INDIRECT b ->
1068     let addr = get_register status (false,false,b) in
1069       { status with external_ram =
1070           WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1071;;
1072
1073let set_arg_16 status wrd =
1074        function
1075                `DPTR ->
1076       let (dh, dl) = from_word wrd in
1077         { status with dph = dh; dpl = dl }
1078
1079let set_flags status c ac ov =
1080 { status with psw =
1081    let bu,bl = from_byte status.psw in
1082    let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1083    let ac = match ac with None -> oac | Some v -> v in
1084      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1085 }
1086;;
1087
1088let xor b1 b2 =
1089  if b1 = true && b2 = true then
1090    false
1091  else if b1 = false && b2 = false then
1092    false
1093  else true
1094;;
1095
1096let read_at_sp status =
1097 let n1,n2 = from_byte status.sp in
1098 let m,r1,r2,r3 = from_nibble n1 in
1099  Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1100   (if m then status.low_internal_ram else status.high_internal_ram)
1101;;
1102
1103let write_at_sp status v =
1104 let n1,n2 = from_byte status.sp in
1105 match from_nibble n1 with
1106    true,r1,r2,r3 ->
1107     let memory =
1108      Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1109     in
1110      { status with low_internal_ram = memory }
1111  | false,r1,r2,r3 ->
1112     let memory =
1113      Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1114     in
1115      { status with high_internal_ram = memory }
1116;;
1117
1118let timer0 status b1 b2 ticks =
1119        let b = get_bit status.tcon 4 in
1120          (* Timer0 first *)
1121          (match b1,b2 with
1122            true,true ->
1123              (* Archaic 13 bit mode. *)
1124              if b then
1125                let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1126                let res = int_of_vect res in
1127                if res > 31 then
1128                  let res = res mod 32 in
1129                  let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1130                    if ov' then
1131                      let b = set_bit status.tcon 7 true in
1132                        { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1133                    else
1134                      { status with th0 = res'; tl0 = vect_of_int res `Eight }
1135                else
1136                  { status with tl0 = vect_of_int res `Eight }
1137              else
1138                status
1139          | false,false ->
1140              (* 8 bit split timer mode. *)
1141              let status = 
1142                (if b then
1143                  let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1144                    if ov then
1145                      let b = set_bit status.tcon 5 true in
1146                        { status with tcon = b; tl0 = res }
1147                    else
1148                      { status with tl0 = res }
1149                else
1150                  status)
1151              in
1152                if get_bit status.tcon 6 then
1153                let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1154                  if ov then
1155                    let b = set_bit status.tcon 7 true in
1156                      { status with tcon = b; th0 = res }
1157                  else
1158                    { status with th0 = res }
1159              else
1160                status
1161          | false,true ->
1162             (* 16 bit timer mode. *)
1163             if b then
1164                let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1165                if ov then
1166                  let b = set_bit status.tcon 5 true in
1167                  let new_th0,new_tl0 = from_word res in
1168                    { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1169                else
1170                  let new_th0,new_tl0 = from_word res in
1171                    { status with th0 = new_th0; tl0 = new_tl0 }
1172              else
1173                status
1174          | true,false ->
1175              (* 8 bit single timer mode. *)
1176              if b then
1177                let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1178                  if ov then
1179                    let b = set_bit status.tcon 5 true in
1180                      { status with tcon = b; tl0 = status.th0; }
1181                  else
1182                    { status with tl0 = res }
1183              else
1184                status)
1185
1186let timer1 status b3 b4 ticks =
1187  let b = get_bit status.tcon 4 in
1188    (match b3,b4 with
1189      true,true ->
1190      (* Archaic 13 bit mode. *)
1191        if b then
1192          let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1193          let res = int_of_vect res in
1194            if res > 31 then
1195              let res = res mod 32 in
1196              let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1197                if ov' then
1198                  let b = set_bit status.tcon 7 true in
1199                    { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1200                else
1201                    { status with th1 = res'; tl0 = vect_of_int res `Eight }
1202              else
1203                { status with tl1 = vect_of_int res `Eight }
1204            else
1205              status
1206          | false,false ->
1207              (* 8 bit split timer mode. *)
1208              let status = 
1209                (if b then
1210                  let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1211                    if ov then
1212                      let b = set_bit status.tcon 5 true in
1213                        { status with tcon = b; tl1 = res }
1214                    else
1215                      { status with tl1 = res }
1216                else
1217                  status)
1218              in
1219                if get_bit status.tcon 6 then
1220                let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1221                  if ov then
1222                    let b = set_bit status.tcon 7 true in
1223                      { status with tcon = b; th1 = res }
1224                  else
1225                    { status with th1 = res }
1226              else
1227                status
1228          | false,true ->
1229             (* 16 bit timer mode. *)
1230             if b then
1231                let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1232                if ov then
1233                  let b = set_bit status.tcon 5 true in
1234                  let new_th1,new_tl1 = from_word res in
1235                    { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1236                else
1237                  let new_th1,new_tl1 = from_word res in
1238                    { status with th1 = new_th1; tl1 = new_tl1 }
1239              else
1240                status
1241          | true,false ->
1242              (* 8 bit single timer mode. *)
1243              if b then
1244                let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1245                  if ov then
1246                    let b = set_bit status.tcon 5 true in
1247                      { status with tcon = b; tl1 = status.th1; }
1248                  else
1249                    { status with tl1 = res }
1250              else
1251                status)
1252
1253let execute1 status =
1254 let instr,pc,ticks = fetch status.code_memory status.pc in
1255 let status = { status with clock = status.clock + ticks; pc = pc } in
1256 let status =
1257   (match instr with
1258     `ADD (`A,d1) ->
1259        let v,c,ac,ov =
1260          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1261        in
1262          set_flags (set_arg_8 status v `A) c (Some ac) ov
1263   | `ADDC (`A,d1) ->
1264        let v,c,ac,ov =
1265          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1266        in
1267          set_flags (set_arg_8 status v `A) c (Some ac) ov
1268   | `SUBB (`A,d1) ->
1269        let v,c,ac,ov =
1270          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1271        in
1272          set_flags (set_arg_8 status v `A) c (Some ac) ov
1273   | `INC `DPTR ->
1274       let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1275       let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1276         { status with dpl = low_order_byte; dph = high_order_byte }
1277   | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1278       let b = get_arg_8 status true d in
1279       let cry, res = half_add b (vect_of_int 1 `Eight) in
1280         set_arg_8 status res d
1281   | `DEC d ->
1282       let b = get_arg_8 status true d in
1283       let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1284         set_arg_8 status res d
1285   | `MUL (`A,`B) ->
1286       let acc = int_of_vect status.acc in
1287       let b = int_of_vect status.b in
1288       let prod = acc * b in
1289       let ov = prod > 255 in
1290       let l = vect_of_int (prod  mod 256) `Eight in
1291       let h = vect_of_int (prod / 256) `Eight in
1292       let status = { status with acc = l ; b = h } in
1293         (* DPM: Carry flag is always cleared. *)
1294         set_flags status false None ov
1295   | `DIV (`A,`B) ->
1296      let acc = int_of_vect status.acc in
1297      let b = int_of_vect status.b in
1298      if b = 0 then
1299        (* CSC: ACC and B undefined! We leave them as they are. *)
1300        set_flags status false None true
1301      else
1302        let q = vect_of_int (acc / b) `Eight in
1303        let r = vect_of_int (acc mod b) `Eight in
1304        let status = { status with acc = q ; b = r } in
1305          set_flags status false None false
1306   | `DA `A ->
1307        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1308          if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1309            let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1310            let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1311            if int_of_vect acc_upper_nibble > 9 or cy = true then
1312              let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1313              let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1314                set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1315            else
1316              status
1317          else
1318            status
1319   | `ANL (`U1(`A, ag)) ->
1320        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1321          set_arg_8 status and_val `A
1322   | `ANL (`U2((`DIRECT d), ag)) ->
1323        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1324          set_arg_8 status and_val (`DIRECT d)
1325   | `ANL (`U3 (`C, b)) ->
1326        let and_val = get_cy_flag status && get_arg_1 status true b in
1327          set_flags status and_val None (get_ov_flag status)
1328   | `ORL (`U1(`A, ag)) ->
1329        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1330          set_arg_8 status or_val `A
1331   | `ORL (`U2((`DIRECT d), ag)) ->
1332        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1333          set_arg_8 status or_val (`DIRECT d)
1334   | `ORL (`U3 (`C, b)) ->
1335        let or_val = get_cy_flag status || get_arg_1 status true b in
1336          set_flags status or_val None (get_ov_flag status)
1337   | `XRL (`U1(`A, ag)) ->
1338        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1339          set_arg_8 status xor_val `A
1340   | `XRL (`U2((`DIRECT d), ag)) ->
1341        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1342          set_arg_8 status xor_val (`DIRECT d)
1343   | `CLR `A -> set_arg_8 status (zero `Eight) `A
1344   | `CLR `C -> set_arg_1 status false `C
1345   | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1346   | `CPL `A -> { status with acc = complement status.acc }
1347   | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1348   | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1349   | `RL `A -> { status with acc = rotate_left status.acc }
1350   | `RLC `A ->
1351        let old_cy = get_cy_flag status in
1352        let n1, n2 = from_byte status.acc in
1353        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1354        let status = set_arg_1 status b1 `C in
1355          { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1356   | `RR `A -> { status with acc = rotate_right status.acc }
1357   | `RRC `A ->
1358        let old_cy = get_cy_flag status in
1359        let n1, n2 = from_byte status.acc in
1360        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1361        let status = set_arg_1 status b8 `C in
1362          { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1363   | `SWAP `A ->
1364        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1365          { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1366  | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1367  | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1368  | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1369  | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1370  | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1371  | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1372  | `MOVC (`A, `A_DPTR) ->
1373     let big_acc = mk_word (zero `Eight) status.acc in
1374     let dptr = mk_word status.dph status.dpl in
1375     let cry, addr = half_add dptr big_acc in
1376     let lookup = WordMap.find addr status.code_memory in
1377       { status with acc = lookup }
1378  | `MOVC (`A, `A_PC) ->
1379     let big_acc = mk_word (zero `Eight) status.acc in
1380     (* DPM: Under specified: does the carry from PC incrementation affect the *)
1381     (*      addition of the PC with the DPTR? At the moment, no.              *)
1382     let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1383     let status = { status with pc = inc_pc } in
1384     let cry,addr = half_add inc_pc big_acc in
1385     let lookup = WordMap.find addr status.code_memory in
1386       { status with acc = lookup }
1387  (* data transfer *)
1388  (* DPM: MOVX currently only implements the *copying* of data! *)
1389  | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1390  | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1391  | `SETB b -> set_arg_1 status true b
1392  | `PUSH (`DIRECT b) ->
1393       (* DPM: What happens if we overflow? *)
1394       let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1395       let status = { status with sp = new_sp } in
1396        write_at_sp status b
1397  | `POP (`DIRECT b) ->
1398       let contents = read_at_sp status in
1399       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1400       let status = { status with sp = new_sp } in
1401       let status = set_arg_8 status contents (`DIRECT b) in
1402         status
1403  | `XCH(`A, arg) ->
1404       let old_arg = get_arg_8 status false arg in
1405       let old_acc = status.acc in
1406       let status = set_arg_8 status old_acc arg in
1407         { status with acc = old_arg }
1408  | `XCHD(`A, i) ->
1409       let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1410       let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1411       let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1412       let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1413       let status = { status with acc = new_acc } in
1414         set_arg_8 status new_reg i
1415 (* program branching *)
1416  | `JC (`REL rel) ->
1417       if get_cy_flag status then
1418         let cry, new_pc = half_add status.pc (sign_extension rel) in
1419           { status with pc = new_pc }
1420       else
1421         status
1422  | `JNC (`REL rel) ->
1423       if not $ get_cy_flag status then
1424         let cry, new_pc = half_add status.pc (sign_extension rel) in
1425           { status with pc = new_pc }
1426       else
1427         status
1428  | `JB (b, (`REL rel)) ->
1429       if get_arg_1 status false b then
1430         let cry, new_pc = half_add status.pc (sign_extension rel) in
1431           { status with pc = new_pc }
1432       else
1433         status
1434  | `JNB (b, (`REL rel)) ->
1435       if not $ get_arg_1 status false b then
1436         let cry, new_pc = half_add status.pc (sign_extension rel) in
1437           { status with pc = new_pc }
1438       else
1439         status
1440  | `JBC (b, (`REL rel)) ->
1441       let status = set_arg_1 status false b in
1442         if get_arg_1 status false b then
1443           let cry, new_pc = half_add status.pc (sign_extension rel) in
1444             { status with pc = new_pc }
1445         else
1446           status
1447  | `RET ->
1448      (* DPM: What happens when we underflow? *)
1449       let high_bits = read_at_sp status in
1450       let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1451       let status = { status with sp = new_sp } in
1452       let low_bits = read_at_sp status in
1453       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1454       let status = { status with sp = new_sp } in
1455         { status with pc = mk_word high_bits low_bits }
1456  | `RETI ->
1457       let high_bits = read_at_sp status in
1458       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1459       let status = { status with sp = new_sp } in
1460       let low_bits = read_at_sp status in
1461       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1462       let status = { status with sp = new_sp } in
1463         { status with pc = mk_word high_bits low_bits }
1464  | `ACALL (`ADDR11 a) ->
1465       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1466       let status = { status with sp = new_sp } in
1467       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1468       let status = write_at_sp status pc_lower_byte in
1469       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1470       let status = { status with sp = new_sp } in
1471       let status = write_at_sp status pc_upper_byte in
1472       let n1, n2 = from_byte pc_upper_byte in
1473       let (b1,b2,b3,_) = from_word11 a in
1474       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1475       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in
1476         { status with pc = addr }
1477  | `LCALL (`ADDR16 addr) ->
1478       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1479       let status = { status with sp = new_sp } in
1480       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1481       let status = write_at_sp status pc_lower_byte in
1482       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1483       let status = { status with sp = new_sp } in
1484       let status = write_at_sp status pc_upper_byte in
1485         { status with pc = addr }
1486  | `AJMP (`ADDR11 a) ->
1487       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1488       let n1, n2 = from_byte pc_upper_byte in
1489       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1490       let (b1,b2,b3,b) = from_word11 a in
1491       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in
1492       let cry, new_pc = half_add status.pc addr in
1493         { status with pc = new_pc }
1494  | `LJMP (`ADDR16 a) ->
1495       { status with pc = a }
1496  | `SJMP (`REL rel) ->
1497       let cry, new_pc = half_add status.pc (sign_extension rel) in
1498         { status with pc = new_pc }
1499  | `JMP `IND_DPTR ->
1500       let dptr = mk_word status.dph status.dpl in
1501       let big_acc = mk_word (zero `Eight) status.acc in
1502       let cry, jmp_addr = half_add big_acc dptr in
1503       let cry, new_pc = half_add status.pc jmp_addr in
1504         { status with pc = new_pc }
1505  | `JZ (`REL rel) ->
1506       if status.acc = zero `Eight then
1507         let cry, new_pc = half_add status.pc (sign_extension rel) in
1508           { status with pc = new_pc }
1509       else
1510         status
1511  | `JNZ (`REL rel) ->
1512       if status.acc <> zero `Eight then
1513         let cry, new_pc = half_add status.pc (sign_extension rel) in
1514                           { status with pc = new_pc }
1515       else
1516         status
1517  | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1518       let new_carry = status.acc < get_arg_8 status false ag in
1519         if get_arg_8 status false ag <> status.acc then
1520           let cry, new_pc = half_add status.pc (sign_extension rel) in
1521           let status = set_flags status new_carry None (get_ov_flag status) in
1522             { status with pc = new_pc;  }
1523         else
1524           set_flags status new_carry None (get_ov_flag status)
1525  | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1526     let new_carry = get_arg_8 status false ag < d in
1527       if get_arg_8 status false ag <> d then
1528         let cry, new_pc = half_add status.pc (sign_extension rel) in
1529         let status = { status with pc = new_pc } in
1530           set_flags status new_carry None (get_ov_flag status)
1531       else
1532         set_flags status new_carry None (get_ov_flag status)
1533  | `DJNZ (ag, (`REL rel)) ->
1534       let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1535       let status = set_arg_8 status new_ag ag in
1536         if new_ag <> zero `Eight then
1537           let cry, new_pc = half_add status.pc (sign_extension rel) in
1538             { status with pc = new_pc }
1539         else
1540           status
1541  | `NOP -> status) in
1542  (* DPM: Clock/Timer code follows. *)
1543  match bits_of_byte status.tmod with
1544(*  | (_,true,_,_),_ -> assert false
1545  | _,(true,_,_,_) -> assert false
1546  | _,(_,true,_,_) -> assert false*)
1547  | (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1548      let status =
1549        (if g0 then
1550          if get_bit status.p3 2 then
1551            timer0 status b1 b2 ticks
1552          else
1553            status
1554        else
1555          timer0 status b1 b2 ticks) in
1556      (* Timer 1 follows. *)
1557      let status =
1558        (if g1 then
1559           if get_bit status.p1 3 then
1560             timer1 status b3 b4 ticks
1561           else
1562             status
1563         else
1564            timer1 status b3 b4 ticks) in
1565       (* Serial port code now follows *)
1566         let in_cont, `Out out_cont = status.io in
1567         let status =
1568           (* Serial port input *)
1569           (match in_cont with
1570             Some (`In(time, line, cont)) when time >= status.clock && get_bit status.scon 4 ->
1571               let status =
1572                 match line with
1573                   `P1 b ->
1574                      { status with p1 = b; p1_latch = b; }
1575                 | `P3 b -> { status with p3 = b; p3_latch = b; }
1576                 | `SerialBuff (`Eight b) ->
1577                      let b7 = get_bit (status.scon) 7 in
1578                        (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1579                        if b7 || get_bit status.scon 5 then
1580                          assert false (* really: crash! *)
1581                        else
1582                          let status = { status with scon = set_bit status.scon 0 true } in
1583                          let status = { status with sbuf = b } in
1584                            status
1585                 | `SerialBuff (`Nine (b,b')) ->
1586                      let b7 = get_bit (status.scon) 7 in
1587                        (* waiting for eight bits *)
1588                        if not b7 then
1589                          assert false (* really: crash! *)
1590                        else
1591                          let status = { status with scon = set_bit status.scon 2 b } in
1592                          let status = { status with sbuf = b' } in
1593                            if (not $ get_bit status.scon 5) || b then
1594                              { status with scon = set_bit status.scon 0 true }
1595                            else
1596                              status
1597               in
1598                 { status with io = cont }
1599           | _ -> status) in
1600           (* Serial port output, part one *)
1601           let status =
1602             (match status.expected_out_time with
1603               `At t when status.clock >= t ->
1604                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1605              | _ -> status) in
1606           (* Serial port output, part two *)
1607           if status.expected_out_time = `Now then
1608             if get_bit status.scon 7 then
1609               let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1610                 { status with expected_out_time = `At exp_time; io = new_cont }
1611             else
1612               let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1613                 { status with expected_out_time = `At exp_time; io = new_cont }               
1614           else
1615             status
1616;;
1617
1618let rec execute f s =
1619 let cont =
1620  try f s; true
1621  with Halt -> false
1622 in
1623  if cont then execute f (execute1 s)
1624  else s
1625;;
Note: See TracBrowser for help on using the repository browser.