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

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

Oops: small change caused compile to fail. Works again, now.

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