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

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

Implemented latch access.

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