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

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

More on implementation of interrupts. Need to add a queue for
interrupts that occur `at the same time' to be executed once interrupts
with higher priority have finished.

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