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

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

Fixed type errors relating to serial output. The serial port code (for
output at least) seems to correctly simulate the compiled C code that I
sent Roberto on Friday.

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_int <*> int_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.