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

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

New features:

1) conditional jumps to labels implemented

[Note: all conditional jumps are to relative addresses;

if the label is too far away, an assert false is currently raised]

2) we now have a preamble of declarations of data labels in external

memory and a new pseudo-instruction "Mov" to place the value of a
data label into DPTR.

File size: 67.0 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 execute1 status =
1119 let instr,pc,ticks = fetch status.code_memory status.pc in
1120 let status = { status with clock = status.clock + ticks; pc = pc } in
1121 let status =
1122   (match instr with
1123     `ADD (`A,d1) ->
1124        let v,c,ac,ov =
1125          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1126        in
1127          set_flags (set_arg_8 status v `A) c (Some ac) ov
1128   | `ADDC (`A,d1) ->
1129        let v,c,ac,ov =
1130          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1131        in
1132          set_flags (set_arg_8 status v `A) c (Some ac) ov
1133   | `SUBB (`A,d1) ->
1134        let v,c,ac,ov =
1135          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1136        in
1137          set_flags (set_arg_8 status v `A) c (Some ac) ov
1138   | `INC `DPTR ->
1139       let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1140       let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1141         { status with dpl = low_order_byte; dph = high_order_byte }
1142   | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1143       let b = get_arg_8 status true d in
1144       let cry, res = half_add b (vect_of_int 1 `Eight) in
1145         set_arg_8 status res d
1146   | `DEC d ->
1147       let b = get_arg_8 status true d in
1148       let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1149         set_arg_8 status res d
1150   | `MUL (`A,`B) ->
1151       let acc = int_of_vect status.acc in
1152       let b = int_of_vect status.b in
1153       let prod = acc * b in
1154       let ov = prod > 255 in
1155       let l = vect_of_int (prod  mod 256) `Eight in
1156       let h = vect_of_int (prod / 256) `Eight in
1157       let status = { status with acc = l ; b = h } in
1158         (* DPM: Carry flag is always cleared. *)
1159         set_flags status false None ov
1160   | `DIV (`A,`B) ->
1161      let acc = int_of_vect status.acc in
1162      let b = int_of_vect status.b in
1163      if b = 0 then
1164        (* CSC: ACC and B undefined! We leave them as they are. *)
1165        set_flags status false None true
1166      else
1167        let q = vect_of_int (acc / b) `Eight in
1168        let r = vect_of_int (acc mod b) `Eight in
1169        let status = { status with acc = q ; b = r } in
1170          set_flags status false None false
1171   | `DA `A ->
1172        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1173          if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1174            let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1175            let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1176            if int_of_vect acc_upper_nibble > 9 or cy = true then
1177              let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1178              let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1179                set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1180            else
1181              status
1182          else
1183            status
1184   | `ANL (`U1(`A, ag)) ->
1185        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1186          set_arg_8 status and_val `A
1187   | `ANL (`U2((`DIRECT d), ag)) ->
1188        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1189          set_arg_8 status and_val (`DIRECT d)
1190   | `ANL (`U3 (`C, b)) ->
1191        let and_val = get_cy_flag status && get_arg_1 status true b in
1192          set_flags status and_val None (get_ov_flag status)
1193   | `ORL (`U1(`A, ag)) ->
1194        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1195          set_arg_8 status or_val `A
1196   | `ORL (`U2((`DIRECT d), ag)) ->
1197        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1198          set_arg_8 status or_val (`DIRECT d)
1199   | `ORL (`U3 (`C, b)) ->
1200        let or_val = get_cy_flag status || get_arg_1 status true b in
1201          set_flags status or_val None (get_ov_flag status)
1202   | `XRL (`U1(`A, ag)) ->
1203        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1204          set_arg_8 status xor_val `A
1205   | `XRL (`U2((`DIRECT d), ag)) ->
1206        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1207          set_arg_8 status xor_val (`DIRECT d)
1208   | `CLR `A -> set_arg_8 status (zero `Eight) `A
1209   | `CLR `C -> set_arg_1 status false `C
1210   | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1211   | `CPL `A -> { status with acc = complement status.acc }
1212   | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1213   | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1214   | `RL `A -> { status with acc = rotate_left status.acc }
1215   | `RLC `A ->
1216        let old_cy = get_cy_flag status in
1217        let n1, n2 = from_byte status.acc in
1218        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1219        let status = set_arg_1 status b1 `C in
1220          { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1221   | `RR `A -> { status with acc = rotate_right status.acc }
1222   | `RRC `A ->
1223        let old_cy = get_cy_flag status in
1224        let n1, n2 = from_byte status.acc in
1225        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1226        let status = set_arg_1 status b8 `C in
1227          { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1228   | `SWAP `A ->
1229        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1230          { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1231  | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1232  | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1233  | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1234  | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1235  | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1236  | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1237  | `MOVC (`A, `A_DPTR) ->
1238     let big_acc = mk_word (zero `Eight) status.acc in
1239     let dptr = mk_word status.dph status.dpl in
1240     let cry, addr = half_add dptr big_acc in
1241     let lookup = WordMap.find addr status.code_memory in
1242       { status with acc = lookup }
1243  | `MOVC (`A, `A_PC) ->
1244     let big_acc = mk_word (zero `Eight) status.acc in
1245     (* DPM: Under specified: does the carry from PC incrementation affect the *)
1246     (*      addition of the PC with the DPTR? At the moment, no.              *)
1247     let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1248     let status = { status with pc = inc_pc } in
1249     let cry,addr = half_add inc_pc big_acc in
1250     let lookup = WordMap.find addr status.code_memory in
1251       { status with acc = lookup }
1252  (* data transfer *)
1253  (* DPM: MOVX currently only implements the *copying* of data! *)
1254  | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1255  | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1256  | `SETB b -> set_arg_1 status true b
1257  | `PUSH (`DIRECT b) ->
1258       (* DPM: What happens if we overflow? *)
1259       let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1260       let status = { status with sp = new_sp } in
1261        write_at_sp status b
1262  | `POP (`DIRECT b) ->
1263       let contents = read_at_sp status in
1264       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1265       let status = { status with sp = new_sp } in
1266       let status = set_arg_8 status contents (`DIRECT b) in
1267         status
1268  | `XCH(`A, arg) ->
1269       let old_arg = get_arg_8 status false arg in
1270       let old_acc = status.acc in
1271       let status = set_arg_8 status old_acc arg in
1272         { status with acc = old_arg }
1273  | `XCHD(`A, i) ->
1274       let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1275       let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1276       let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1277       let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1278       let status = { status with acc = new_acc } in
1279         set_arg_8 status new_reg i
1280 (* program branching *)
1281  | `JC (`REL rel) ->
1282       if get_cy_flag status then
1283         let cry, new_pc = half_add status.pc (sign_extension rel) in
1284           { status with pc = new_pc }
1285       else
1286         status
1287  | `JNC (`REL rel) ->
1288       if not $ get_cy_flag status then
1289         let cry, new_pc = half_add status.pc (sign_extension rel) in
1290           { status with pc = new_pc }
1291       else
1292         status
1293  | `JB (b, (`REL rel)) ->
1294       if get_arg_1 status false b then
1295         let cry, new_pc = half_add status.pc (sign_extension rel) in
1296           { status with pc = new_pc }
1297       else
1298         status
1299  | `JNB (b, (`REL rel)) ->
1300       if not $ get_arg_1 status false b then
1301         let cry, new_pc = half_add status.pc (sign_extension rel) in
1302           { status with pc = new_pc }
1303       else
1304         status
1305  | `JBC (b, (`REL rel)) ->
1306       let status = set_arg_1 status false b in
1307         if get_arg_1 status false b then
1308           let cry, new_pc = half_add status.pc (sign_extension rel) in
1309             { status with pc = new_pc }
1310         else
1311           status
1312  | `RET ->
1313      (* DPM: What happens when we underflow? *)
1314       let high_bits = read_at_sp status in
1315       let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1316       let status = { status with sp = new_sp } in
1317       let low_bits = read_at_sp status in
1318       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1319       let status = { status with sp = new_sp } in
1320         { status with pc = mk_word high_bits low_bits }
1321  | `RETI ->
1322       let high_bits = read_at_sp status in
1323       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1324       let status = { status with sp = new_sp } in
1325       let low_bits = read_at_sp status in
1326       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1327       let status = { status with sp = new_sp } in
1328         { status with pc = mk_word high_bits low_bits }
1329  | `ACALL (`ADDR11 a) ->
1330       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1331       let status = { status with sp = new_sp } in
1332       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1333       let status = write_at_sp status pc_lower_byte in
1334       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1335       let status = { status with sp = new_sp } in
1336       let status = write_at_sp status pc_upper_byte in
1337       let n1, n2 = from_byte pc_upper_byte in
1338       let (b1,b2,b3,_) = from_word11 a in
1339       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1340       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in
1341         { status with pc = addr }
1342  | `LCALL (`ADDR16 addr) ->
1343       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1344       let status = { status with sp = new_sp } in
1345       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1346       let status = write_at_sp status pc_lower_byte in
1347       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1348       let status = { status with sp = new_sp } in
1349       let status = write_at_sp status pc_upper_byte in
1350         { status with pc = addr }
1351  | `AJMP (`ADDR11 a) ->
1352       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1353       let n1, n2 = from_byte pc_upper_byte in
1354       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1355       let (b1,b2,b3,b) = from_word11 a in
1356       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in
1357       let cry, new_pc = half_add status.pc addr in
1358         { status with pc = new_pc }
1359  | `LJMP (`ADDR16 a) ->
1360       { status with pc = a }
1361  | `SJMP (`REL rel) ->
1362       let cry, new_pc = half_add status.pc (sign_extension rel) in
1363         { status with pc = new_pc }
1364  | `JMP `IND_DPTR ->
1365       let dptr = mk_word status.dph status.dpl in
1366       let big_acc = mk_word (zero `Eight) status.acc in
1367       let cry, jmp_addr = half_add big_acc dptr in
1368       let cry, new_pc = half_add status.pc jmp_addr in
1369         { status with pc = new_pc }
1370  | `JZ (`REL rel) ->
1371       if status.acc = zero `Eight then
1372         let cry, new_pc = half_add status.pc (sign_extension rel) in
1373           { status with pc = new_pc }
1374       else
1375         status
1376  | `JNZ (`REL rel) ->
1377       if status.acc <> zero `Eight then
1378         let cry, new_pc = half_add status.pc (sign_extension rel) in
1379                           { status with pc = new_pc }
1380       else
1381         status
1382  | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1383       let new_carry = status.acc < get_arg_8 status false ag in
1384         if get_arg_8 status false ag <> status.acc then
1385           let cry, new_pc = half_add status.pc (sign_extension rel) in
1386           let status = set_flags status new_carry None (get_ov_flag status) in
1387             { status with pc = new_pc;  }
1388         else
1389           set_flags status new_carry None (get_ov_flag status)
1390  | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1391     let new_carry = get_arg_8 status false ag < d in
1392       if get_arg_8 status false ag <> d then
1393         let cry, new_pc = half_add status.pc (sign_extension rel) in
1394         let status = { status with pc = new_pc } in
1395           set_flags status new_carry None (get_ov_flag status)
1396       else
1397         set_flags status new_carry None (get_ov_flag status)
1398  | `DJNZ (ag, (`REL rel)) ->
1399       let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1400       let status = set_arg_8 status new_ag ag in
1401         if new_ag <> zero `Eight then
1402           let cry, new_pc = half_add status.pc (sign_extension rel) in
1403             { status with pc = new_pc }
1404         else
1405           status
1406  | `NOP -> status) in
1407  (* DPM: Clock/Timer code follows. *)
1408  match bits_of_byte status.tmod with
1409    (true,_,_,_),_ -> assert false
1410  | (_,true,_,_),_ -> assert false
1411  | _,(true,_,_,_) -> assert false
1412  | _,(_,true,_,_) -> assert false
1413  | (_,_,b1,b2),(_,_,b3,b4) ->
1414        let b = get_bit status.tcon 4 in
1415        let status = 
1416          (* Timer0 first *)
1417          (match b1,b2 with
1418            true,true ->
1419              (* Archaic 13 bit mode. *)
1420              if b then
1421                let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1422                let res = int_of_vect res in
1423                if res > 31 then
1424                  let res = res mod 32 in
1425                  let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1426                    if ov' then
1427                      let b = set_bit status.tcon 7 true in
1428                        { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1429                    else
1430                      { status with th0 = res'; tl0 = vect_of_int res `Eight }
1431                else
1432                  { status with tl0 = vect_of_int res `Eight }
1433              else
1434                status
1435          | false,false ->
1436              (* 8 bit split timer mode. *)
1437              let status = 
1438                (if b then
1439                  let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1440                    if ov then
1441                      let b = set_bit status.tcon 5 true in
1442                        { status with tcon = b; tl0 = res }
1443                    else
1444                      { status with tl0 = res }
1445                else
1446                  status)
1447              in
1448                if get_bit status.tcon 6 then
1449                let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1450                  if ov then
1451                    let b = set_bit status.tcon 7 true in
1452                      { status with tcon = b; th0 = res }
1453                  else
1454                    { status with th0 = res }
1455              else
1456                status
1457          | false,true ->
1458             (* 16 bit timer mode. *)
1459             if b then
1460                let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1461                if ov then
1462                  let b = set_bit status.tcon 5 true in
1463                  let new_th0,new_tl0 = from_word res in
1464                    { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1465                else
1466                  let new_th0,new_tl0 = from_word res in
1467                    { status with th0 = new_th0; tl0 = new_tl0 }
1468              else
1469                status
1470          | true,false ->
1471              (* 8 bit single timer mode. *)
1472              if b then
1473                let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1474                  if ov then
1475                    let b = set_bit status.tcon 5 true in
1476                      { status with tcon = b; tl0 = status.th0; }
1477                  else
1478                    { status with tl0 = res }
1479              else
1480                status) in
1481          (* Timer 1 follows. *)
1482        let status =
1483          (match b3,b4 with
1484            true,true ->
1485              (* Archaic 13 bit mode. *)
1486              if b then
1487                let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1488                let res = int_of_vect res in
1489                if res > 31 then
1490                  let res = res mod 32 in
1491                  let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1492                    if ov' then
1493                      let b = set_bit status.tcon 7 true in
1494                        { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1495                    else
1496                      { status with th1 = res'; tl0 = vect_of_int res `Eight }
1497                else
1498                  { status with tl1 = vect_of_int res `Eight }
1499              else
1500                status
1501          | false,false ->
1502              (* 8 bit split timer mode. *)
1503              let status = 
1504                (if b then
1505                  let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1506                    if ov then
1507                      let b = set_bit status.tcon 5 true in
1508                        { status with tcon = b; tl1 = res }
1509                    else
1510                      { status with tl1 = res }
1511                else
1512                  status)
1513              in
1514                if get_bit status.tcon 6 then
1515                let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1516                  if ov then
1517                    let b = set_bit status.tcon 7 true in
1518                      { status with tcon = b; th1 = res }
1519                  else
1520                    { status with th1 = res }
1521              else
1522                status
1523          | false,true ->
1524             (* 16 bit timer mode. *)
1525             if b then
1526                let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1527                if ov then
1528                  let b = set_bit status.tcon 5 true in
1529                  let new_th1,new_tl1 = from_word res in
1530                    { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1531                else
1532                  let new_th1,new_tl1 = from_word res in
1533                    { status with th1 = new_th1; tl1 = new_tl1 }
1534              else
1535                status
1536          | true,false ->
1537              (* 8 bit single timer mode. *)
1538              if b then
1539                let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1540                  if ov then
1541                    let b = set_bit status.tcon 5 true in
1542                      { status with tcon = b; tl1 = status.th1; }
1543                  else
1544                    { status with tl1 = res }
1545              else
1546                status) in
1547       (* Serial port code now follows *)
1548         let in_cont, `Out out_cont = status.io in
1549         let status =
1550           (* Serial port input *)
1551           (match in_cont with
1552             Some (`In(time, line, cont)) when time >= status.clock && get_bit status.scon 4 ->
1553               let status =
1554                 match line with
1555                   `P1 b -> assert false
1556                 | `P3 b -> assert false
1557                 | `SerialBuff (`Eight b) ->
1558                      let b7 = get_bit (status.scon) 7 in
1559                        (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1560                        if b7 || get_bit status.scon 5 then
1561                          assert false (* really: crash! *)
1562                        else
1563                          let status = { status with scon = set_bit status.scon 0 true } in
1564                          let status = { status with sbuf = b } in
1565                            status
1566                 | `SerialBuff (`Nine (b,b')) ->
1567                      let b7 = get_bit (status.scon) 7 in
1568                        (* waiting for eight bits *)
1569                        if not b7 then
1570                          assert false (* really: crash! *)
1571                        else
1572                          let status = { status with scon = set_bit status.scon 2 b } in
1573                          let status = { status with sbuf = b' } in
1574                            if (not $ get_bit status.scon 5) || b then
1575                              { status with scon = set_bit status.scon 0 true }
1576                            else
1577                              status
1578               in
1579                 { status with io = cont }
1580           | _ -> status) in
1581           (* Serial port output, part one *)
1582           let status =
1583             (match status.expected_out_time with
1584               `At t when status.clock >= t ->
1585                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1586              | _ -> status) in
1587           (* Serial port output, part two *)
1588           if status.expected_out_time = `Now then
1589             if get_bit status.scon 7 then
1590               let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1591                 { status with expected_out_time = `At exp_time; io = new_cont }
1592             else
1593               let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1594                 { status with expected_out_time = `At exp_time; io = new_cont }               
1595           else
1596             status
1597;;
1598
1599let rec execute f s =
1600 let cont =
1601  try f s; true
1602  with Halt -> false
1603 in
1604  if cont then execute f (execute1 s)
1605  else s
1606;;
Note: See TracBrowser for help on using the repository browser.