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

Last change on this file since 198 was 198, checked in by mulligan, 10 years ago

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