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

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

I/O support added for serial buffer.

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