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

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

Added printout of processor status when we enter the infinite SJMP loop
at the end. Need to add printout of register status, though. Every
other important SFR, etc. is already implemented.

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