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

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

Interrupts are harder than they look.

File size: 80.0 KB
Line 
1open BitVectors;;
2open Physical;;
3open ASM;;
4open Pretty;;
5open IntelHex;;
6open Util;;
7open Parser;;
8
9exception Fetch_exception of string;;
10exception CodeTooLarge;;
11exception Halt;;
12
13type time = int;;
14type line = [ `P1 of byte
15            | `P3 of byte
16            | `SerialBuff of [ `Eight of byte | `Nine of BitVectors.bit * byte ]];;
17
18let string_of_line =
19  function
20    `P1 b ->
21       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
22       "P1 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
23       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
24  | `P3 b ->
25       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
26       "P2 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
27       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
28  | `SerialBuff (`Eight b) ->
29       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
30       "SERIAL 8b OUTPUT: " ^ string_of_vect b ^ "\n" ^
31       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
32  | `SerialBuff (`Nine (b, b')) ->
33       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
34       "SERIAL 9b OUTPUT: " ^
35          (let i = int_of_vect b' in
36            if b then
37              string_of_int (128 + i)
38          else
39             string_of_int i) ^
40       "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
41
42(* In:  reception time, line of input, new continuation,
43   Out: transmission time, output line, expected duration until reply,
44        new continuation.
45*)
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))]
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    status
1340;;
1341
1342let serial_port_input status in_cont =
1343    (* Serial port input *)
1344      match in_cont with
1345        Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1346          (let status =
1347            (match line with
1348              `P1 b ->
1349                 if status.clock >= time then
1350                   { status with p1 = b; p1_latch = b; }
1351                 else
1352                   status
1353            | `P3 b ->
1354                 if status.clock >= time then
1355                   { status with p3 = b; p3_latch = b; }
1356                 else
1357                   status
1358            | `SerialBuff (`Eight b) ->
1359                 let sm0 = get_bit status.scon 7 in
1360                 let sm1 = get_bit status.scon 6 in
1361                   (match (sm0, sm1) with
1362                     (false, false) ->
1363                       (* Mode 0: shift register.  No delay. *)
1364                       if status.clock >= time then
1365                         { status with scon = set_bit status.scon 0 true;
1366                                       io   = cont;
1367                                       sbuf = b }
1368                       else
1369                         status
1370                   | (false, true) ->
1371                       (* Mode 1: 8-bit UART *)
1372                       (* Explanation: 8 bit asynchronous communication.  There's a delay (epsilon)
1373                          which needs taking care of.  If we're trying to communicate at the same time
1374                          an existing communication is occurring, we assert false (else clause of first
1375                          if). *)
1376                       if status.serial_epsilon_in = None && status.serial_v_in = None then
1377                         if status.clock >= time then
1378                           (* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1379                           if get_bit status.scon 5 then
1380                             assert false (* really: crash! *)
1381                           else
1382                             { status with serial_epsilon_in = Some (epsilon + time);
1383                                           serial_v_in       = Some (`Eight b) }
1384                         else
1385                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1386                              None. *)
1387                           let Some e = status.serial_epsilon_in in
1388                           let Some v = status.serial_v_in in
1389                             if status.clock >= e then
1390                               match v with
1391                                 `Eight v' ->
1392                                   { status with sbuf = v';
1393                                                 serial_v_in = None;
1394                                                 serial_epsilon_in = None;
1395                                                 scon = set_bit status.scon 0 true;
1396                                                 io = cont }
1397                               | _ -> assert false (* trying to read in 9 bits instead of 8 *)
1398                             else
1399                               status
1400                       else
1401                         assert false
1402                   | (true, false) | (true, true) ->
1403                       assert false (* only got eight bits on the line when in 9 bit mode *))
1404             | `SerialBuff (`Nine (b,b')) ->
1405                 let sm0 = get_bit status.scon 7 in
1406                 let sm1 = get_bit status.scon 6 in
1407                   match(sm0, sm1) with
1408                     (false, false) | (false, true) -> assert false
1409                   | (true, false)  | (true, true) ->
1410                       (* Modes 2 and 3: 9-bit UART *)
1411                       (* Explanation: 9 bit asynchronous communication.  There's a delay (epsilon)
1412                          which needs taking care of.  If we're trying to communicate at the same time
1413                          an existing communication is occurring, we assert false (else claus of first
1414                          if). *)
1415                       if status.serial_epsilon_in = None && status.serial_v_in = None then
1416                         if status.clock >= time then
1417                           (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1418                           if get_bit status.scon 5 then
1419                             assert false (* really: crash! *)
1420                           else
1421                             { status with serial_epsilon_in = Some (epsilon + time);
1422                                           serial_v_in       = Some (`Nine (b, b')) }
1423                         else
1424                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1425                              None. *)
1426                           let Some e = status.serial_epsilon_in in
1427                           let Some v = status.serial_v_in in
1428                             if status.clock >= e then
1429                               match v with
1430                                 `Nine (v, v') ->
1431                                    let scon' = set_bit status.scon 0 true in
1432                                      { status with sbuf = v';
1433                                                    serial_v_in = None;
1434                                                    serial_epsilon_in = None;
1435                                                    scon = set_bit scon' 2 b;
1436                                                    io = cont }
1437                               | _ -> assert false (* trying to read in 8 bits instead of 9 *)
1438                             else
1439                               status
1440                       else
1441                         assert false)
1442           in
1443             { status with io = cont })
1444       | _ -> status
1445;;
1446
1447let serial_port_output status out_cont =
1448  (* Serial port output *)
1449    (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1450                                serial_v_out = Some (`Eight status.sbuf);
1451                                serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1452    match status.serial_epsilon_out with
1453      Some s ->
1454        if status.clock >= s then
1455          match status.serial_k_out with
1456            None -> assert false (* correct? *)
1457          | Some k' -> { status with io   = k';
1458                                     scon = set_bit status.scon 1 true; }
1459        else
1460          status
1461     | _ -> assert false)
1462;;
1463
1464let external_serial_interrupt status esi =
1465  (* Interrupt enabled *)
1466  if esi then
1467    (* If we're already running, then fine (todo: check for *another* interrupt
1468       and add to a queue, or something? *)
1469    if status.t1i_running then
1470      status
1471    else
1472      (* If we should be running, but aren't... *)
1473      if false then
1474        assert false
1475      else
1476        status
1477  else
1478    status
1479;;
1480
1481let external0_interrupt status e0i =
1482  (* Interrupt enabled *)
1483  if e0i then
1484    (* If we're already running, then fine (todo: check for *another* interrupt
1485       and add to a queue, or something? *)
1486    if status.t1i_running then
1487      status
1488    else
1489      (* If we should be running, but aren't... *)
1490      if false then
1491        assert false
1492      else
1493        status
1494  else
1495    status
1496;;
1497
1498let external1_interrupt status e1i =
1499  (* Interrupt enabled *)
1500  if e1i then
1501    (* If we're already running, then fine (todo: check for *another* interrupt
1502       and add to a queue, or something? *)
1503    if status.t1i_running then
1504      status
1505    else
1506      (* If we should be running, but aren't... *)
1507      if false then
1508        assert false
1509      else
1510        status
1511  else
1512    status
1513;;
1514
1515let timer0_interrupt status t0i =
1516  (* Interrupt enabled *)
1517  if t0i then
1518    (* If we're already running, then fine (todo: check for *another* interrupt
1519       and add to a queue, or something? *)
1520    if status.t1i_running then
1521      status
1522    else
1523      (* If we should be running, but aren't... *)
1524      if false then
1525        assert false
1526      else
1527        status
1528  else
1529    status
1530;;
1531
1532let timer1_interrupt status t1i =
1533  (* Interrupt enabled *)
1534  if t1i then
1535    (* If we're already running, then fine (todo: check for *another* interrupt
1536       and add to a queue, or something? *)
1537    if status.t1i_running then
1538      status
1539    else
1540      (* If we should be running, but aren't... *)
1541      if false then
1542        assert false
1543      else
1544        status
1545  else
1546    status
1547;;
1548
1549let interrupts status =
1550  let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1551  let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1552    (* DPM: are interrupts enabled? *)
1553    if ea then
1554      match (ps,pt1,px1,pt0,px0) with
1555        (* Check priorities of interrupts *)
1556        (false,false,false,false,false) ->
1557          (* Standard priority, so just do regular polling sequence *)
1558          let status = external0_interrupt status ex0 in
1559          let status = timer0_interrupt status et0 in
1560          let status = external1_interrupt status ex1 in
1561          let status = timer1_interrupt status et1 in
1562          let status = external_serial_interrupt status es in
1563            status
1564      | (true,false,false,false,false) ->
1565          if status.es_running then
1566            (* External interrupt is currently running, and cannot be interrupted *)
1567            status
1568          else
1569            (* Standard priority, so just do regular polling sequence *)
1570            let status = external0_interrupt status ex0 in
1571            let status = timer0_interrupt status et0 in
1572            let status = external1_interrupt status ex1 in
1573            let status = timer1_interrupt status et1 in
1574            let status = external_serial_interrupt status es in
1575              status
1576      | (false,true,false,false,false) ->
1577          if status.t1i_running then
1578            (* Timer1 interrupt is currently running, and cannot be interrupted *)
1579            status
1580          else
1581            (* Standard priority, so just do regular polling sequence *)
1582            let status = external0_interrupt status ex0 in
1583            let status = timer0_interrupt status et0 in
1584            let status = external1_interrupt status ex1 in
1585            let status = timer1_interrupt status et1 in
1586            let status = external_serial_interrupt status es in
1587              status
1588      | (false,false,true,false,false) ->
1589          if status.e1i_running then
1590            (* External1 interrupt is currently running, and cannot be interrupted *)
1591            status
1592          else
1593            (* Standard priority, so just do regular polling sequence *)
1594            let status = external0_interrupt status ex0 in
1595            let status = timer0_interrupt status et0 in
1596            let status = external1_interrupt status ex1 in
1597            let status = timer1_interrupt status et1 in
1598            let status = external_serial_interrupt status es in
1599              status
1600      | (false,false,false,true,false) ->
1601          if status.t0i_running then
1602            (* Timer0 interrupt is currently running, and cannot be interrupted *)
1603            status
1604          else
1605            (* Standard priority, so just do regular polling sequence *)
1606            let status = external0_interrupt status ex0 in
1607            let status = timer0_interrupt status et0 in
1608            let status = external1_interrupt status ex1 in
1609            let status = timer1_interrupt status et1 in
1610            let status = external_serial_interrupt status es in
1611              status
1612      | (false,false,false,false,true) ->
1613          if status.e0i_running then
1614            (* External0 interrupt is currently running, and cannot be interrupted *)
1615            status
1616          else
1617            (* Standard priority, so just do regular polling sequence *)
1618            let status = external0_interrupt status ex0 in
1619            let status = timer0_interrupt status et0 in
1620            let status = external1_interrupt status ex1 in
1621            let status = timer1_interrupt status et1 in
1622            let status = external_serial_interrupt status es in
1623              status
1624      | (false,true,true,false,false) ->
1625          if status.t1i_running && status.e1i_running then
1626            (* Cannot have two interrupts with same priority running together *)
1627            assert false
1628          else if status.t1i_running || status.e1i_running then
1629            status
1630          else
1631            (* Standard priority, so just do regular polling sequence *)
1632            let status = external0_interrupt status ex0 in
1633            let status = timer0_interrupt status et0 in
1634            let status = external1_interrupt status ex1 in
1635            let status = timer1_interrupt status et1 in
1636            let status = external_serial_interrupt status es in
1637              status
1638    else
1639      status
1640;;
1641
1642let execute1 status =
1643 let instr,pc,ticks = fetch status.code_memory status.pc in
1644 let status = { status with clock = status.clock + ticks; pc = pc } in
1645 let status =
1646   (match instr with
1647     `ADD (`A,d1) ->
1648        let v,c,ac,ov =
1649          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1650        in
1651          set_flags (set_arg_8 status v `A) c (Some ac) ov
1652   | `ADDC (`A,d1) ->
1653        let v,c,ac,ov =
1654          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1655        in
1656          set_flags (set_arg_8 status v `A) c (Some ac) ov
1657   | `SUBB (`A,d1) ->
1658        let v,c,ac,ov =
1659          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1660        in
1661          set_flags (set_arg_8 status v `A) c (Some ac) ov
1662   | `INC `DPTR ->
1663       let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1664       let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1665         { status with dpl = low_order_byte; dph = high_order_byte }
1666   | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1667       let b = get_arg_8 status true d in
1668       let cry, res = half_add b (vect_of_int 1 `Eight) in
1669         set_arg_8 status res d
1670   | `DEC d ->
1671       let b = get_arg_8 status true d in
1672       let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1673         set_arg_8 status res d
1674   | `MUL (`A,`B) ->
1675       let acc = int_of_vect status.acc in
1676       let b = int_of_vect status.b in
1677       let prod = acc * b in
1678       let ov = prod > 255 in
1679       let l = vect_of_int (prod  mod 256) `Eight in
1680       let h = vect_of_int (prod / 256) `Eight in
1681       let status = { status with acc = l ; b = h } in
1682         (* DPM: Carry flag is always cleared. *)
1683         set_flags status false None ov
1684   | `DIV (`A,`B) ->
1685      let acc = int_of_vect status.acc in
1686      let b = int_of_vect status.b in
1687      if b = 0 then
1688        (* CSC: ACC and B undefined! We leave them as they are. *)
1689        set_flags status false None true
1690      else
1691        let q = vect_of_int (acc / b) `Eight in
1692        let r = vect_of_int (acc mod b) `Eight in
1693        let status = { status with acc = q ; b = r } in
1694          set_flags status false None false
1695   | `DA `A ->
1696        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1697          if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1698            let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1699            let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1700            if int_of_vect acc_upper_nibble > 9 or cy = true then
1701              let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1702              let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1703                set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1704            else
1705              status
1706          else
1707            status
1708   | `ANL (`U1(`A, ag)) ->
1709        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1710          set_arg_8 status and_val `A
1711   | `ANL (`U2((`DIRECT d), ag)) ->
1712        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1713          set_arg_8 status and_val (`DIRECT d)
1714   | `ANL (`U3 (`C, b)) ->
1715        let and_val = get_cy_flag status && get_arg_1 status true b in
1716          set_flags status and_val None (get_ov_flag status)
1717   | `ORL (`U1(`A, ag)) ->
1718        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1719          set_arg_8 status or_val `A
1720   | `ORL (`U2((`DIRECT d), ag)) ->
1721        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1722          set_arg_8 status or_val (`DIRECT d)
1723   | `ORL (`U3 (`C, b)) ->
1724        let or_val = get_cy_flag status || get_arg_1 status true b in
1725          set_flags status or_val None (get_ov_flag status)
1726   | `XRL (`U1(`A, ag)) ->
1727        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1728          set_arg_8 status xor_val `A
1729   | `XRL (`U2((`DIRECT d), ag)) ->
1730        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1731          set_arg_8 status xor_val (`DIRECT d)
1732   | `CLR `A -> set_arg_8 status (zero `Eight) `A
1733   | `CLR `C -> set_arg_1 status false `C
1734   | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1735   | `CPL `A -> { status with acc = complement status.acc }
1736   | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1737   | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1738   | `RL `A -> { status with acc = rotate_left status.acc }
1739   | `RLC `A ->
1740        let old_cy = get_cy_flag status in
1741        let n1, n2 = from_byte status.acc in
1742        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1743        let status = set_arg_1 status b1 `C in
1744          { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1745   | `RR `A -> { status with acc = rotate_right status.acc }
1746   | `RRC `A ->
1747        let old_cy = get_cy_flag status in
1748        let n1, n2 = from_byte status.acc in
1749        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1750        let status = set_arg_1 status b8 `C in
1751          { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1752   | `SWAP `A ->
1753        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1754          { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1755  | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1756  | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1757  | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1758  | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1759  | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1760  | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1761  | `MOVC (`A, `A_DPTR) ->
1762     let big_acc = mk_word (zero `Eight) status.acc in
1763     let dptr = mk_word status.dph status.dpl in
1764     let cry, addr = half_add dptr big_acc in
1765     let lookup = WordMap.find addr status.code_memory in
1766       { status with acc = lookup }
1767  | `MOVC (`A, `A_PC) ->
1768     let big_acc = mk_word (zero `Eight) status.acc in
1769     (* DPM: Under specified: does the carry from PC incrementation affect the *)
1770     (*      addition of the PC with the DPTR? At the moment, no.              *)
1771     let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1772     let status = { status with pc = inc_pc } in
1773     let cry,addr = half_add inc_pc big_acc in
1774     let lookup = WordMap.find addr status.code_memory in
1775       { status with acc = lookup }
1776  (* data transfer *)
1777  (* DPM: MOVX currently only implements the *copying* of data! *)
1778  | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1779  | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1780  | `SETB b -> set_arg_1 status true b
1781  | `PUSH (`DIRECT b) ->
1782       (* DPM: What happens if we overflow? *)
1783       let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1784       let status = { status with sp = new_sp } in
1785        write_at_sp status b
1786  | `POP (`DIRECT b) ->
1787       let contents = read_at_sp status in
1788       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1789       let status = { status with sp = new_sp } in
1790       let status = set_arg_8 status contents (`DIRECT b) in
1791         status
1792  | `XCH(`A, arg) ->
1793       let old_arg = get_arg_8 status false arg in
1794       let old_acc = status.acc in
1795       let status = set_arg_8 status old_acc arg in
1796         { status with acc = old_arg }
1797  | `XCHD(`A, i) ->
1798       let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1799       let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1800       let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1801       let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1802       let status = { status with acc = new_acc } in
1803         set_arg_8 status new_reg i
1804 (* program branching *)
1805  | `JC (`REL rel) ->
1806       if get_cy_flag status then
1807         let cry, new_pc = half_add status.pc (sign_extension rel) in
1808           { status with pc = new_pc }
1809       else
1810         status
1811  | `JNC (`REL rel) ->
1812       if not $ get_cy_flag status then
1813         let cry, new_pc = half_add status.pc (sign_extension rel) in
1814           { status with pc = new_pc }
1815       else
1816         status
1817  | `JB (b, (`REL rel)) ->
1818       if get_arg_1 status false b then
1819         let cry, new_pc = half_add status.pc (sign_extension rel) in
1820           { status with pc = new_pc }
1821       else
1822         status
1823  | `JNB (b, (`REL rel)) ->
1824       if not $ get_arg_1 status false b then
1825         let cry, new_pc = half_add status.pc (sign_extension rel) in
1826           { status with pc = new_pc }
1827       else
1828         status
1829  | `JBC (b, (`REL rel)) ->
1830       let status = set_arg_1 status false b in
1831         if get_arg_1 status false b then
1832           let cry, new_pc = half_add status.pc (sign_extension rel) in
1833             { status with pc = new_pc }
1834         else
1835           status
1836  | `RET ->
1837      (* DPM: What happens when we underflow? *)
1838       let high_bits = read_at_sp status in
1839       let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1840       let status = { status with sp = new_sp } in
1841       let low_bits = read_at_sp status in
1842       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1843       let status = { status with sp = new_sp } in
1844         { status with pc = mk_word high_bits low_bits }
1845  | `RETI ->
1846       let high_bits = read_at_sp status in
1847       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1848       let status = { status with sp = new_sp } in
1849       let low_bits = read_at_sp status in
1850       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1851       let status = { status with sp = new_sp } in
1852         { status with pc = mk_word high_bits low_bits }
1853  | `ACALL (`ADDR11 a) ->
1854       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1855       let status = { status with sp = new_sp } in
1856       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1857       let status = write_at_sp status pc_lower_byte in
1858       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1859       let status = { status with sp = new_sp } in
1860       let status = write_at_sp status pc_upper_byte in
1861       let n1, n2 = from_byte pc_upper_byte in
1862       let (b1,b2,b3,_) = from_word11 a in
1863       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1864       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in
1865         { status with pc = addr }
1866  | `LCALL (`ADDR16 addr) ->
1867       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1868       let status = { status with sp = new_sp } in
1869       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1870       let status = write_at_sp status pc_lower_byte in
1871       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1872       let status = { status with sp = new_sp } in
1873       let status = write_at_sp status pc_upper_byte in
1874         { status with pc = addr }
1875  | `AJMP (`ADDR11 a) ->
1876       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1877       let n1, n2 = from_byte pc_upper_byte in
1878       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1879       let (b1,b2,b3,b) = from_word11 a in
1880       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in
1881       let cry, new_pc = half_add status.pc addr in
1882         { status with pc = new_pc }
1883  | `LJMP (`ADDR16 a) ->
1884       { status with pc = a }
1885  | `SJMP (`REL rel) ->
1886       let cry, new_pc = half_add status.pc (sign_extension rel) in
1887         { status with pc = new_pc }
1888  | `JMP `IND_DPTR ->
1889       let dptr = mk_word status.dph status.dpl in
1890       let big_acc = mk_word (zero `Eight) status.acc in
1891       let cry, jmp_addr = half_add big_acc dptr in
1892       let cry, new_pc = half_add status.pc jmp_addr in
1893         { status with pc = new_pc }
1894  | `JZ (`REL rel) ->
1895       if status.acc = zero `Eight then
1896         let cry, new_pc = half_add status.pc (sign_extension rel) in
1897           { status with pc = new_pc }
1898       else
1899         status
1900  | `JNZ (`REL rel) ->
1901       if status.acc <> zero `Eight then
1902         let cry, new_pc = half_add status.pc (sign_extension rel) in
1903                           { status with pc = new_pc }
1904       else
1905         status
1906  | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1907       let new_carry = status.acc < get_arg_8 status false ag in
1908         if get_arg_8 status false ag <> status.acc then
1909           let cry, new_pc = half_add status.pc (sign_extension rel) in
1910           let status = set_flags status new_carry None (get_ov_flag status) in
1911             { status with pc = new_pc;  }
1912         else
1913           set_flags status new_carry None (get_ov_flag status)
1914  | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1915     let new_carry = get_arg_8 status false ag < d in
1916       if get_arg_8 status false ag <> d then
1917         let cry, new_pc = half_add status.pc (sign_extension rel) in
1918         let status = { status with pc = new_pc } in
1919           set_flags status new_carry None (get_ov_flag status)
1920       else
1921         set_flags status new_carry None (get_ov_flag status)
1922  | `DJNZ (ag, (`REL rel)) ->
1923       let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1924       let status = set_arg_8 status new_ag ag in
1925         if new_ag <> zero `Eight then
1926           let cry, new_pc = half_add status.pc (sign_extension rel) in
1927             { status with pc = new_pc }
1928         else
1929           status
1930  | `NOP -> status) in
1931  let status = timers status ticks in
1932  let in_cont, `Out out_cont = status.io in
1933  let status = serial_port_input status in_cont in
1934  let status = serial_port_output status out_cont in
1935  let status = interrupts status in
1936    { status with previous_p1_val = get_bit status.p3 4;
1937                  previous_p3_val = get_bit status.p3 5 }
1938;;
1939
1940(*
1941OLD output routine:
1942           (* Serial port output, part one *)
1943           let status =
1944             (match status.expected_out_time with
1945               `At t when status.clock >= t ->
1946                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1947              | _ -> status) in
1948
1949             (if status.expected_out_time = `Now then
1950               if get_bit status.scon 7 then
1951                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1952                   { status with expected_out_time = `At exp_time; io = new_cont }
1953               else
1954                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1955                   { status with expected_out_time = `At exp_time; io = new_cont }               
1956             else
1957               status) in
1958*)
1959
1960let rec execute f s =
1961 let cont =
1962  try f s; true
1963  with Halt -> false
1964 in
1965  if cont then execute f (execute1 s)
1966  else s
1967;;
Note: See TracBrowser for help on using the repository browser.