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

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

Improvements to processor status output. Now includes readout of main
utility registers (R0--R7).

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