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

Last change on this file since 304 was 280, checked in by sacerdot, 10 years ago

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