Context Navigation

source: Deliverables/D2.2/8051/src/ASM/ASMInterpret.ml @ 627

Last change on this file since 627 was 627, checked in by mulligan, 10 years ago
Fixed bug in ASMInterpret.ml. Added pretty printing module.
File size: 79.5 KB

Line
1	open BitVectors;;
2	open Physical;;
3	open ASM;;
4	open IntelHex;;
5	open Util;;
6	open Parser;;
7
8	exception Fetch_exception of string;;
9	exception CodeTooLarge;;
10	exception Halt;;
11
12	type time = int;;
13	type line = [ `P1 of byte
14	\| `P3 of byte
15	\| `SerialBuff of [ `Eight of byte \| `Nine of BitVectors.bit * byte ]];;
16
17	let string_of_line =
18	function
19	`P1 b ->
20	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
21	"P1 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
22	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
23	\| `P3 b ->
24	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
25	"P2 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
26	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
27	\| `SerialBuff (`Eight b) ->
28	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
29	"SERIAL 8b OUTPUT: " ^ string_of_vect b ^ "\n" ^
30	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
31	\| `SerialBuff (`Nine (b, b')) ->
32	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
33	"SERIAL 9b OUTPUT: " ^
34	(let i = int_of_vect b' in
35	if b then
36	string_of_int (128 + i)
37	else
38	string_of_int i) ^
39	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
40
41	(* In: reception time, line of input, new continuation,
42	Out: transmission time, output line, expected duration until reply,
43	new continuation.
44	*)
45
46	type epsilon = int
47
48	type continuation =
49	[`In of time * line * epsilon * continuation] option *
50	[`Out of (time -> line -> time * continuation)]
51
52	let rec debug_continuation =
53	(Some (`In (1, (`SerialBuff (`Eight (vect_of_int 5 `Eight))), 0, debug_continuation))), `Out (
54	fun time line ->
55	(* let _ = prerr_endline <> string_of_line $ line in )
56	(time + 1),debug_continuation)
57
58	(* no differentiation between internal and external code memory *)
59	type status =
60	{
61	(* Memory *)
62	code_memory: Physical.WordMap.map; (* can be reduced *)
63	low_internal_ram: Byte7Map.map;
64	high_internal_ram: Byte7Map.map;
65	external_ram: Physical.WordMap.map;
66
67	(* Program counter *)
68	pc: word;
69
70	(* SFRs *)
71	sp: byte;
72	dpl: byte;
73	dph: byte;
74	pcon: byte;
75	tcon: byte;
76	tmod: byte;
77	tl0: byte;
78	tl1: byte;
79	th0: byte;
80	th1: byte;
81	p1: byte;
82	scon: byte;
83	sbuf: byte;
84	ie: byte;
85	p3: byte;
86	ip: byte;
87	psw: byte;
88	acc: byte;
89	b: byte;
90	t2con: byte; (* 8052 only *)
91	rcap2l: byte; (* 8052 only *)
92	rcap2h: byte; (* 8052 only *)
93	tl2: byte; (* 8052 only *)
94	th2: byte; (* 8052 only *)
95
96	(* Latches for the output lines *)
97	p1_latch: byte;
98	p3_latch: byte;
99
100	(* Fields for tracking the state of the processor. *)
101
102	(* IO specific *)
103	previous_p1_val: bool;
104	previous_p3_val: bool;
105
106	serial_epsilon_out: epsilon option;
107	serial_epsilon_in: epsilon option;
108
109	io_epsilon: epsilon;
110
111	serial_v_in: [`Eight of byte \| `Nine of (BitVectors.bit * byte) ] option;
112	serial_v_out: [`Eight of byte \| `Nine of (BitVectors.bit * byte) ] option;
113
114	serial_k_out: continuation option;
115
116	io: continuation;
117	expected_out_time: [ `None \| `Now \| `At of time ];
118
119	(* Timer and clock specific *)
120	clock: time;
121	timer0: word;
122	timer1: word;
123	timer2: word; (* can be missing *)
124
125	esi_running: bool;
126	t0i_running: bool;
127	t1i_running: bool;
128	e0i_running: bool;
129	e1i_running: bool;
130	es_running: bool;
131
132	exit_addr : BitVectors.word;
133	cost_labels : string BitVectors.WordMap.t
134	}
135
136	(* Try to understand what DEC really does!!! *)
137	(* Try to understand I/O *)
138	let get_sfr status addr from_latch =
139	match int_of_vect addr with
140	(* I/O and timer ports *)
141	0x80 -> assert false (* P0 not modeled *)
142	\| 0x90 ->
143	if from_latch then
144	status.p1_latch
145	else status.p1
146	\| 0xA0 -> assert false (* P2 not modeled *)
147	\| 0xB0 ->
148	if from_latch then
149	status.p3_latch
150	else status.p3
151	\| 0x99 -> status.sbuf
152	\| 0x8A -> status.tl0
153	\| 0x8B -> status.tl1
154	\| 0x8C -> status.th0
155	\| 0x8D -> status.th1
156	\| 0xC8 -> status.t2con
157	\| 0xCA -> status.rcap2l
158	\| 0xCB -> status.rcap2h
159	\| 0xCC -> status.tl2
160	\| 0xCD -> status.th2
161
162	(* control ports *)
163	\| 0x87 -> status.pcon
164	\| 0x88 -> status.tcon
165	\| 0x89 -> status.tmod
166	\| 0x98 -> status.scon
167	\| 0xA8 -> status.ie
168	\| 0xB8 -> status.ip
169
170	(* registers *)
171	\| 0x81 -> status.sp
172	\| 0x82 -> status.dpl
173	\| 0x83 -> status.dph
174	\| 0xD0 -> status.psw
175	\| 0xE0 -> status.acc
176	\| 0xF0 -> status.b
177	\| _ -> assert false
178	;;
179
180	(* Try to understand I/O *)
181	let set_sfr status addr v =
182	match int_of_vect addr with
183	(* I/O and timer ports *)
184	0x80 -> assert false (* P0 not modeled *)
185	\| 0x90 -> { status with p1 = v; p1_latch = v }
186	\| 0xA0 -> assert false (* P2 not modeled *)
187	\| 0xB0 -> { status with p3 = v; p3_latch = v }
188	\| 0x99 ->
189	if status.expected_out_time = `None then
190	{ status with sbuf = v; expected_out_time = `Now }
191	else
192	(* a real assert false: trying to initiate a transmission whilst one is still active *)
193	assert false
194	\| 0x8A -> { status with tl0 = v }
195	\| 0x8B -> { status with tl1 = v }
196	\| 0x8C -> { status with th0 = v }
197	\| 0x8D -> { status with th1 = v }
198	\| 0xC8 -> { status with t2con = v }
199	\| 0xCA -> { status with rcap2l = v }
200	\| 0xCB -> { status with rcap2h = v }
201	\| 0xCD -> { status with tl2 = v }
202	\| 0xCE -> { status with th2 = v }
203
204	(* control ports *)
205	\| 0x87 -> { status with pcon = v }
206	\| 0x88 -> { status with tcon = v }
207	\| 0x89 -> { status with tmod = v }
208	\| 0x98 -> { status with scon = v }
209	\| 0xA8 -> { status with ie = v }
210	\| 0xB8 -> { status with ip = v }
211
212	(* registers *)
213	\| 0x81 -> { status with sp = v }
214	\| 0x82 -> { status with dpl = v }
215	\| 0x83 -> { status with dph = v }
216	\| 0xD0 -> { status with psw = v }
217	\| 0xE0 -> { status with acc = v }
218	\| 0xF0 -> { status with b = v }
219	\| _ -> assert false
220	;;
221
222	let initialize = {
223	code_memory = Physical.WordMap.empty;
224	low_internal_ram = Byte7Map.empty;
225	high_internal_ram = Byte7Map.empty;
226	external_ram = Physical.WordMap.empty;
227
228	pc = zero `Sixteen;
229
230	sp = vect_of_int 7 `Eight;
231	dpl = zero `Eight;
232	dph = zero `Eight;
233	pcon = zero `Eight;
234	tcon = zero `Eight;
235	tmod = zero `Eight;
236	tl0 = zero `Eight;
237	tl1 = zero `Eight;
238	th0 = zero `Eight;
239	th1 = zero `Eight;
240	p1 = zero `Eight;
241	p1_latch = zero `Eight;
242	scon = zero `Eight;
243	sbuf = zero `Eight;
244	ie = zero `Eight;
245	p3 = zero `Eight;
246	p3_latch = zero `Eight;
247	ip = zero `Eight;
248	psw = zero `Eight;
249	acc = zero `Eight;
250	b = zero `Eight;
251	t2con = zero `Eight;
252	rcap2l = zero `Eight;
253	rcap2h = zero `Eight;
254	tl2 = zero `Eight;
255	th2 = zero `Eight;
256
257	previous_p1_val = false;
258	previous_p3_val = false;
259
260	serial_v_in = None;
261	serial_v_out = None;
262	serial_epsilon_in = None;
263	serial_epsilon_out = None;
264	serial_k_out = None;
265
266	io_epsilon = 5;
267
268	clock = 0;
269	timer0 = zero `Sixteen;
270	timer1 = zero `Sixteen;
271	timer2 = zero `Sixteen;
272
273	expected_out_time = `None;
274
275	io = debug_continuation; (* a real assert false: unprepared for i/o *)
276
277	(* Initially no interrupts are executing *)
278	esi_running = false;
279	t0i_running = false;
280	t1i_running = false;
281	e0i_running = false;
282	e1i_running = false;
283	es_running = false;
284
285	exit_addr = BitVectors.zero `Sixteen;
286	cost_labels = BitVectors.WordMap.empty
287	}
288
289	let get_cy_flag status =
290	let (cy,_,_,_),(_,_,_,_) = bits_of_byte status.psw in cy
291	let get_ac_flag status =
292	let (_,ac,_,_),(_,_,_,_) = bits_of_byte status.psw in ac
293	let get_fo_flag status =
294	let (_,_,fo,_),(_,_,_,_) = bits_of_byte status.psw in fo
295	let get_rs1_flag status =
296	let (_,_,_,rs1),(_,_,_,_) = bits_of_byte status.psw in rs1
297	let get_rs0_flag status =
298	let (_,_,_,_),(rs0,_,_,_) = bits_of_byte status.psw in rs0
299	let get_ov_flag status =
300	let (_,_,_,_),(_,ov,_,_) = bits_of_byte status.psw in ov
301	let get_ud_flag status =
302	let (_,_,_,_),(_,_,ud,_) = bits_of_byte status.psw in ud
303	let get_p_flag status =
304	let (_,_,_,_),(_,_,_,p) = bits_of_byte status.psw in p
305
306	let get_address_of_register status (b1,b2,b3) =
307	let bu,_bl = from_byte status.psw in
308	let (_,_,rs1,rs0) = from_nibble bu in
309	let base =
310	match rs1,rs0 with
311	false,false -> 0x00
312	\| false,true -> 0x08
313	\| true,false -> 0x10
314	\| true,true -> 0x18
315	in
316	vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven
317	;;
318
319	let get_register status reg =
320	let addr = get_address_of_register status reg in
321	Byte7Map.find addr status.low_internal_ram
322	;;
323
324	let string_of_status status =
325	let acc_str = (string_of_int <*> int_of_vect $ status.acc) ^ " (" ^ string_of_vect status.acc ^ ")" in
326	let b_str = (string_of_int <*> int_of_vect $ status.b) ^ " (" ^ string_of_vect status.b ^ ")" in
327	let psw_str = (string_of_int <*> int_of_vect $ status.psw) ^ " (" ^ string_of_vect status.psw ^ ")" in
328	let sp_str = (string_of_int <*> int_of_vect $ status.sp) ^ " (" ^ string_of_vect status.sp ^ ")" in
329	let ip_str = (string_of_int <*> int_of_vect $ status.ip) ^ " (" ^ string_of_vect status.ip ^ ")" in
330	let pc_str = (string_of_int <*> int_of_vect $ status.pc) ^ " (" ^ string_of_vect status.pc ^ ")" in
331	let dpl_str = (string_of_int <*> int_of_vect $ status.dpl) ^ " (" ^ string_of_vect status.dpl ^ ")" in
332	let dph_str = (string_of_int <*> int_of_vect $ status.dph) ^ " (" ^ string_of_vect status.dph ^ ")" in
333	let scn_str = (string_of_int <*> int_of_vect $ status.scon) ^ " (" ^ string_of_vect status.scon ^ ")" in
334	let sbf_str = (string_of_int <*> int_of_vect $ status.sbuf) ^ " (" ^ string_of_vect status.sbuf ^ ")" in
335	let tcn_str = (string_of_int <*> int_of_vect $ status.tcon) ^ " (" ^ string_of_vect status.tcon ^ ")" in
336	let tmd_str = (string_of_int <*> int_of_vect $ status.tmod) ^ " (" ^ string_of_vect status.tmod ^ ")" in
337	let r0_str = (string_of_int <*> int_of_vect $ get_register status (false, false, false)) ^ " (" ^ (string_of_vect $ get_register status (false, false, false)) ^ ")" in
338	let r1_str = (string_of_int <*> int_of_vect $ get_register status (false, false, true)) ^ " (" ^ (string_of_vect $ get_register status (false, false, true)) ^ ")" in
339	let r2_str = (string_of_int <*> int_of_vect $ get_register status (false, true, false)) ^ " (" ^ (string_of_vect $ get_register status (false, true, false)) ^ ")" in
340	let r3_str = (string_of_int <*> int_of_vect $ get_register status (false, true, true)) ^ " (" ^ (string_of_vect $ get_register status (false, true, true)) ^ ")" in
341	let r4_str = (string_of_int <*> int_of_vect $ get_register status (true, false, false)) ^ " (" ^ (string_of_vect $ get_register status (true, false, false)) ^ ")" in
342	let r5_str = (string_of_int <*> int_of_vect $ get_register status (true, false, true)) ^ " (" ^ (string_of_vect $ get_register status (true, false, true)) ^ ")" in
343	let r6_str = (string_of_int <*> int_of_vect $ get_register status (true, true, false)) ^ " (" ^ (string_of_vect $ get_register status (true, true, false)) ^ ")" in
344	let r7_str = (string_of_int <*> int_of_vect $ get_register status (true, true, true)) ^ " (" ^ (string_of_vect $ get_register status (true, true, true)) ^ ")" in
345	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
346	" Processor status: \n" ^
347	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
348	" ACC : " ^ acc_str ^ "\n" ^
349	" B : " ^ b_str ^ "\n" ^
350	" PSW : " ^ psw_str ^ "\n" ^
351	" with flags set as \n" ^
352	" CY : " ^ (string_of_bool <*> get_cy_flag $ status) ^ "\n" ^
353	" AC : " ^ (string_of_bool <*> get_ac_flag $ status) ^ "\n" ^
354	" FO : " ^ (string_of_bool <*> get_fo_flag $ status) ^ "\n" ^
355	" RS1 : " ^ (string_of_bool <*> get_rs1_flag $ status) ^ "\n" ^
356	" RS0 : " ^ (string_of_bool <*> get_rs0_flag $ status) ^ "\n" ^
357	" OV : " ^ (string_of_bool <*> get_ov_flag $ status) ^ "\n" ^
358	" UD : " ^ (string_of_bool <*> get_ud_flag $ status) ^ "\n" ^
359	" P : " ^ (string_of_bool <*> get_p_flag $ status) ^ "\n" ^
360	" SP : " ^ sp_str ^ "\n" ^
361	" IP : " ^ ip_str ^ "\n" ^
362	" PC : " ^ pc_str ^ "\n" ^
363	" DPL : " ^ dpl_str ^ "\n" ^
364	" DPH : " ^ dph_str ^ "\n" ^
365	" SCON: " ^ scn_str ^ "\n" ^
366	" SBUF: " ^ sbf_str ^ "\n" ^
367	" TMOD: " ^ tmd_str ^ "\n" ^
368	" TCON: " ^ tcn_str ^ "\n" ^
369	" Registers: \n" ^
370	" R0 : " ^ r0_str ^ "\n" ^
371	" R1 : " ^ r1_str ^ "\n" ^
372	" R2 : " ^ r2_str ^ "\n" ^
373	" R3 : " ^ r3_str ^ "\n" ^
374	" R4 : " ^ r4_str ^ "\n" ^
375	" R5 : " ^ r5_str ^ "\n" ^
376	" R6 : " ^ r6_str ^ "\n" ^
377	" R7 : " ^ r7_str ^ "\n" ^
378	"-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
379
380	(* timings taken from SIEMENS *)
381
382	let fetch pmem pc =
383	let next pc =
384	let _carry, res = half_add pc (vect_of_int 1 `Sixteen) in
385	res, Physical.WordMap.find pc pmem
386	in
387	let pc,instr = next pc in
388	let un, ln = from_byte instr in
389	let bits = (from_nibble un, from_nibble ln) in
390	match bits with
391	(a10,a9,a8,true),(false,false,false,true) ->
392	let pc,b1 = next pc in
393	`ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
394	\| (false,false,true,false),(true,r1,r2,r3) ->
395	`ADD (`A,`REG (r1,r2,r3)), pc, 1
396	\| (false,false,true,false),(false,true,false,true) ->
397	let pc,b1 = next pc in
398	`ADD (`A,`DIRECT b1), pc, 1
399	\| (false,false,true,false),(false,true,true,i1) ->
400	`ADD (`A,`INDIRECT i1), pc, 1
401	\| (false,false,true,false),(false,true,false,false) ->
402	let pc,b1 = next pc in
403	`ADD (`A,`DATA b1), pc, 1
404	\| (false,false,true,true),(true,r1,r2,r3) ->
405	`ADDC (`A,`REG (r1,r2,r3)), pc, 1
406	\| (false,false,true,true),(false,true,false,true) ->
407	let pc,b1 = next pc in
408	`ADDC (`A,`DIRECT b1), pc, 1
409	\| (false,false,true,true),(false,true,true,i1) ->
410	`ADDC (`A,`INDIRECT i1), pc, 1
411	\| (false,false,true,true),(false,true,false,false) ->
412	let pc,b1 = next pc in
413	`ADDC (`A,`DATA b1), pc, 1
414	\| (a10,a9,a8,false),(false,false,false,true) ->
415	let pc,b1 = next pc in
416	`AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
417	\| (false,true,false,true),(true,r1,r2,r3) ->
418	`ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1
419	\| (false,true,false,true),(false,true,false,true) ->
420	let pc,b1 = next pc in
421	`ANL (`U1 (`A, `DIRECT b1)), pc, 1
422	\| (false,true,false,true),(false,true,true,i1) ->
423	`ANL (`U1 (`A, `INDIRECT i1)), pc, 1
424	\| (false,true,false,true),(false,true,false,false) ->
425	let pc,b1 = next pc in
426	`ANL (`U1 (`A, `DATA b1)), pc, 1
427	\| (false,true,false,true),(false,false,true,false) ->
428	let pc,b1 = next pc in
429	`ANL (`U2 (`DIRECT b1,`A)), pc, 1
430	\| (false,true,false,true),(false,false,true,true) ->
431	let pc,b1 = next pc in
432	let pc,b2 = next pc in
433	`ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2
434	\| (true,false,false,false),(false,false,true,false) ->
435	let pc,b1 = next pc in
436	`ANL (`U3 (`C,`BIT b1)), pc, 2
437	\| (true,false,true,true),(false,false,false,false) ->
438	let pc,b1 = next pc in
439	`ANL (`U3 (`C,`NBIT b1)), pc, 2
440	\| (true,false,true,true),(false,true,false,true) ->
441	let pc,b1 = next pc in
442	let pc,b2 = next pc in
443	`CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2
444	\| (true,false,true,true),(false,true,false,false) ->
445	let pc,b1 = next pc in
446	let pc,b2 = next pc in
447	`CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2
448	\| (true,false,true,true),(true,r1,r2,r3) ->
449	let pc,b1 = next pc in
450	let pc,b2 = next pc in
451	`CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2
452	\| (true,false,true,true),(false,true,true,i1) ->
453	let pc,b1 = next pc in
454	let pc,b2 = next pc in
455	`CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2
456	\| (true,true,true,false),(false,true,false,false) ->
457	`CLR `A, pc, 1
458	\| (true,true,false,false),(false,false,true,true) ->
459	`CLR `C, pc, 1
460	\| (true,true,false,false),(false,false,true,false) ->
461	let pc,b1 = next pc in
462	`CLR (`BIT b1), pc, 1
463	\| (true,true,true,true),(false,true,false,false) ->
464	`CPL `A, pc, 1
465	\| (true,false,true,true),(false,false,true,true) ->
466	`CPL `C, pc, 1
467	\| (true,false,true,true),(false,false,true,false) ->
468	let pc,b1 = next pc in
469	`CPL (`BIT b1), pc, 1
470	\| (true,true,false,true),(false,true,false,false) ->
471	`DA `A, pc, 1
472	\| (false,false,false,true),(false,true,false,false) ->
473	`DEC `A, pc, 1
474	\| (false,false,false,true),(true,r1,r2,r3) ->
475	`DEC (`REG(r1,r2,r3)), pc, 1
476	\| (false,false,false,true),(false,true,false,true) ->
477	let pc,b1 = next pc in
478	`DEC (`DIRECT b1), pc, 1
479	\| (false,false,false,true),(false,true,true,i1) ->
480	`DEC (`INDIRECT i1), pc, 1
481	\| (true,false,false,false),(false,true,false,false) ->
482	`DIV (`A, `B), pc, 4
483	\| (true,true,false,true),(true,r1,r2,r3) ->
484	let pc,b1 = next pc in
485	`DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2
486	\| (true,true,false,true),(false,true,false,true) ->
487	let pc,b1 = next pc in
488	let pc,b2 = next pc in
489	`DJNZ (`DIRECT b1, `REL b2), pc, 2
490	\| (false,false,false,false),(false,true,false,false) ->
491	`INC `A, pc, 1
492	\| (false,false,false,false),(true,r1,r2,r3) ->
493	`INC (`REG(r1,r2,r3)), pc, 1
494	\| (false,false,false,false),(false,true,false,true) ->
495	let pc,b1 = next pc in
496	`INC (`DIRECT b1), pc, 1
497	\| (false,false,false,false),(false,true,true,i1) ->
498	`INC (`INDIRECT i1), pc, 1
499	\| (true,false,true,false),(false,false,true,true) ->
500	`INC `DPTR, pc, 2
501	\| (false,false,true,false),(false,false,false,false) ->
502	let pc,b1 = next pc in
503	let pc,b2 = next pc in
504	`JB (`BIT b1, `REL b2), pc, 2
505	\| (false,false,false,true),(false,false,false,false) ->
506	let pc,b1 = next pc in
507	let pc,b2 = next pc in
508	`JBC (`BIT b1, `REL b2), pc, 2
509	\| (false,true,false,false),(false,false,false,false) ->
510	let pc,b1 = next pc in
511	`JC (`REL b1), pc, 2
512	\| (false,true,true,true),(false,false,true,true) ->
513	`JMP `IND_DPTR, pc, 2
514	\| (false,false,true,true),(false,false,false,false) ->
515	let pc,b1 = next pc in
516	let pc,b2 = next pc in
517	`JNB (`BIT b1, `REL b2), pc, 2
518	\| (false,true,false,true),(false,false,false,false) ->
519	let pc,b1 = next pc in
520	`JNC (`REL b1), pc, 2
521	\| (false,true,true,true),(false,false,false,false) ->
522	let pc,b1 = next pc in
523	`JNZ (`REL b1), pc, 2
524	\| (false,true,true,false),(false,false,false,false) ->
525	let pc,b1 = next pc in
526	`JZ (`REL b1), pc, 2
527	\| (false,false,false,true),(false,false,true,false) ->
528	let pc,b1 = next pc in
529	let pc,b2 = next pc in
530	`LCALL (`ADDR16 (mk_word b1 b2)), pc, 2
531	\| (false,false,false,false),(false,false,true,false) ->
532	let pc,b1 = next pc in
533	let pc,b2 = next pc in
534	`LJMP (`ADDR16 (mk_word b1 b2)), pc, 2
535	\| (true,true,true,false),(true,r1,r2,r3) ->
536	`MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1
537	\| (true,true,true,false),(false,true,false,true) ->
538	let pc,b1 = next pc in
539	`MOV (`U1 (`A, `DIRECT b1)), pc, 1
540	\| (true,true,true,false),(false,true,true,i1) ->
541	`MOV (`U1 (`A, `INDIRECT i1)), pc, 1
542	\| (false,true,true,true),(false,true,false,false) ->
543	let pc,b1 = next pc in
544	`MOV (`U1 (`A, `DATA b1)), pc, 1
545	\| (true,true,true,true),(true,r1,r2,r3) ->
546	`MOV (`U2 (`REG(r1,r2,r3), `A)), pc, 1
547	\| (true,false,true,false),(true,r1,r2,r3) ->
548	let pc,b1 = next pc in
549	`MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))), pc, 2
550	\| (false,true,true,true),(true,r1,r2,r3) ->
551	let pc,b1 = next pc in
552	`MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))), pc, 1
553	\| (true,true,true,true),(false,true,false,true) ->
554	let pc,b1 = next pc in
555	`MOV (`U3 (`DIRECT b1, `A)), pc, 1
556	\| (true,false,false,false),(true,r1,r2,r3) ->
557	let pc,b1 = next pc in
558	`MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))), pc, 2
559	\| (true,false,false,false),(false,true,false,true) ->
560	let pc,b1 = next pc in
561	let pc,b2 = next pc in
562	`MOV (`U3 (`DIRECT b1, `DIRECT b2)), pc, 2
563	\| (true,false,false,false),(false,true,true,i1) ->
564	let pc,b1 = next pc in
565	`MOV (`U3 (`DIRECT b1, `INDIRECT i1)), pc, 2
566	\| (false,true,true,true),(false,true,false,true) ->
567	let pc,b1 = next pc in
568	let pc,b2 = next pc in
569	`MOV (`U3 (`DIRECT b1, `DATA b2)), pc, 3
570	\| (true,true,true,true),(false,true,true,i1) ->
571	`MOV (`U2 (`INDIRECT i1, `A)), pc, 1
572	\| (true,false,true,false),(false,true,true,i1) ->
573	let pc,b1 = next pc in
574	`MOV (`U2 (`INDIRECT i1, `DIRECT b1)), pc, 2
575	\| (false,true,true,true),(false,true,true,i1) ->
576	let pc,b1 = next pc in
577	`MOV (`U2 (`INDIRECT i1, `DATA b1)), pc, 1
578	\| (true,false,true,false),(false,false,true,false) ->
579	let pc,b1 = next pc in
580	`MOV (`U5 (`C, `BIT b1)), pc, 1
581	\| (true,false,false,true),(false,false,true,false) ->
582	let pc,b1 = next pc in
583	`MOV (`U6 (`BIT b1, `C)), pc, 2
584	\| (true,false,false,true),(false,false,false,false) ->
585	let pc,b1 = next pc in
586	let pc,b2 = next pc in
587	`MOV (`U4 (`DPTR, `DATA16(mk_word b1 b2))), pc, 2
588	\| (true,false,false,true),(false,false,true,true) ->
589	`MOVC (`A, `A_DPTR), pc, 2
590	\| (true,false,false,false),(false,false,true,true) ->
591	`MOVC (`A, `A_PC), pc, 2
592	\| (true,true,true,false),(false,false,true,i1) ->
593	`MOVX (`U1 (`A, `EXT_INDIRECT i1)), pc, 2
594	\| (true,true,true,false),(false,false,false,false) ->
595	`MOVX (`U1 (`A, `EXT_IND_DPTR)), pc, 2
596	\| (true,true,true,true),(false,false,true,i1) ->
597	`MOVX (`U2 (`EXT_INDIRECT i1, `A)), pc, 2
598	\| (true,true,true,true),(false,false,false,false) ->
599	`MOVX (`U2 (`EXT_IND_DPTR, `A)), pc, 2
600	\| (true,false,true,false),(false,true,false,false) ->
601	`MUL(`A, `B), pc, 4
602	\| (false,false,false,false),(false,false,false,false) ->
603	`NOP, pc, 1
604	\| (false,true,false,false),(true,r1,r2,r3) ->
605	`ORL (`U1(`A, `REG(r1,r2,r3))), pc, 1
606	\| (false,true,false,false),(false,true,false,true) ->
607	let pc,b1 = next pc in
608	`ORL (`U1(`A, `DIRECT b1)), pc, 1
609	\| (false,true,false,false),(false,true,true,i1) ->
610	`ORL (`U1(`A, `INDIRECT i1)), pc, 1
611	\| (false,true,false,false),(false,true,false,false) ->
612	let pc,b1 = next pc in
613	`ORL (`U1(`A, `DATA b1)), pc, 1
614	\| (false,true,false,false),(false,false,true,false) ->
615	let pc,b1 = next pc in
616	`ORL (`U2(`DIRECT b1, `A)), pc, 1
617	\| (false,true,false,false),(false,false,true,true) ->
618	let pc,b1 = next pc in
619	let pc,b2 = next pc in
620	`ORL (`U2 (`DIRECT b1, `DATA b2)), pc, 2
621	\| (false,true,true,true),(false,false,true,false) ->
622	let pc,b1 = next pc in
623	`ORL (`U3 (`C, `BIT b1)), pc, 2
624	\| (true,false,true,false),(false,false,false,false) ->
625	let pc,b1 = next pc in
626	`ORL (`U3 (`C, `NBIT b1)), pc, 2
627	\| (true,true,false,true),(false,false,false,false) ->
628	let pc,b1 = next pc in
629	`POP (`DIRECT b1), pc, 2
630	\| (true,true,false,false),(false,false,false,false) ->
631	let pc,b1 = next pc in
632	`PUSH (`DIRECT b1), pc, 2
633	\| (false,false,true,false),(false,false,true,false) ->
634	`RET, pc, 2
635	\| (false,false,true,true),(false,false,true,false) ->
636	`RETI, pc, 2
637	\| (false,false,true,false),(false,false,true,true) ->
638	`RL `A, pc, 1
639	\| (false,false,true,true),(false,false,true,true) ->
640	`RLC `A, pc, 1
641	\| (false,false,false,false),(false,false,true,true) ->
642	`RR `A, pc, 1
643	\| (false,false,false,true),(false,false,true,true) ->
644	`RRC `A, pc, 1
645	\| (true,true,false,true),(false,false,true,true) ->
646	`SETB `C, pc, 1
647	\| (true,true,false,true),(false,false,true,false) ->
648	let pc,b1 = next pc in
649	`SETB (`BIT b1), pc, 1
650	\| (true,false,false,false),(false,false,false,false) ->
651	let pc,b1 = next pc in
652	`SJMP (`REL b1), pc, 2
653	\| (true,false,false,true),(true,r1,r2,r3) ->
654	`SUBB (`A, `REG(r1,r2,r3)), pc, 1
655	\| (true,false,false,true),(false,true,false,true) ->
656	let pc,b1 = next pc in
657	`SUBB (`A, `DIRECT b1), pc, 1
658	\| (true,false,false,true),(false,true,true,i1) ->
659	`SUBB (`A, `INDIRECT i1), pc, 1
660	\| (true,false,false,true),(false,true,false,false) ->
661	let pc,b1 = next pc in
662	`SUBB (`A, `DATA b1), pc, 1
663	\| (true,true,false,false),(false,true,false,false) ->
664	`SWAP `A, pc, 1
665	\| (true,true,false,false),(true,r1,r2,r3) ->
666	`XCH (`A, `REG(r1,r2,r3)), pc, 1
667	\| (true,true,false,false),(false,true,false,true) ->
668	let pc,b1 = next pc in
669	`XCH (`A, `DIRECT b1), pc, 1
670	\| (true,true,false,false),(false,true,true,i1) ->
671	`XCH (`A, `INDIRECT i1), pc, 1
672	\| (true,true,false,true),(false,true,true,i1) ->
673	`XCHD(`A, `INDIRECT i1), pc, 1
674	\| (false,true,true,false),(true,r1,r2,r3) ->
675	`XRL(`U1(`A, `REG(r1,r2,r3))), pc, 1
676	\| (false,true,true,false),(false,true,false,true) ->
677	let pc,b1 = next pc in
678	`XRL(`U1(`A, `DIRECT b1)), pc, 1
679	\| (false,true,true,false),(false,true,true,i1) ->
680	`XRL(`U1(`A, `INDIRECT i1)), pc, 1
681	\| (false,true,true,false),(false,true,false,false) ->
682	let pc,b1 = next pc in
683	`XRL(`U1(`A, `DATA b1)), pc, 1
684	\| (false,true,true,false),(false,false,true,false) ->
685	let pc,b1 = next pc in
686	`XRL(`U2(`DIRECT b1, `A)), pc, 1
687	\| (false,true,true,false),(false,false,true,true) ->
688	let pc,b1 = next pc in
689	let pc,b2 = next pc in
690	`XRL(`U2(`DIRECT b1, `DATA b2)), pc, 2
691	\| (true,false,true,false),(false,true,false,true) ->
692	(* undefined opcode *) assert false
693	;;
694
695	let assembly1 =
696	function
697	`ACALL (`ADDR11 w) ->
698	let (a10,a9,a8,b1) = from_word11 w in
699	[mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
700	\| `ADD (`A,`REG (r1,r2,r3)) ->
701	[mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
702	\| `ADD (`A, `DIRECT b1) ->
703	[mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
704	\| `ADD (`A, `INDIRECT i1) ->
705	[mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
706	\| `ADD (`A, `DATA b1) ->
707	[mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
708	\| `ADDC (`A, `REG(r1,r2,r3)) ->
709	[mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
710	\| `ADDC (`A, `DIRECT b1) ->
711	[mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
712	\| `ADDC (`A,`INDIRECT i1) ->
713	[mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
714	\| `ADDC (`A,`DATA b1) ->
715	[mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
716	\| `AJMP (`ADDR11 w) ->
717	let (a10,a9,a8,b1) = from_word11 w in
718	[mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true)); b1]
719	\| `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
720	[mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
721	\| `ANL (`U1 (`A, `DIRECT b1)) ->
722	[mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
723	\| `ANL (`U1 (`A, `INDIRECT i1)) ->
724	[mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
725	\| `ANL (`U1 (`A, `DATA b1)) ->
726	[mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
727	\| `ANL (`U2 (`DIRECT b1,`A)) ->
728	[mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
729	\| `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
730	[mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
731	\| `ANL (`U3 (`C,`BIT b1)) ->
732	[mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
733	\| `ANL (`U3 (`C,`NBIT b1)) ->
734	[mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
735	\| `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
736	[mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
737	\| `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
738	[mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
739	\| `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
740	[mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
741	\| `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
742	[mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
743	\| `CLR `A ->
744	[mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
745	\| `CLR `C ->
746	[mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
747	\| `CLR (`BIT b1) ->
748	[mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
749	\| `CPL `A ->
750	[mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
751	\| `CPL `C ->
752	[mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
753	\| `CPL (`BIT b1) ->
754	[mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
755	\| `DA `A ->
756	[mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
757	\| `DEC `A ->
758	[mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
759	\| `DEC (`REG(r1,r2,r3)) ->
760	[mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
761	\| `DEC (`DIRECT b1) ->
762	[mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
763	\| `DEC (`INDIRECT i1) ->
764	[mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
765	\| `DIV (`A, `B) ->
766	[mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
767	\| `DJNZ (`REG(r1,r2,r3), `REL b1) ->
768	[mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
769	\| `DJNZ (`DIRECT b1, `REL b2) ->
770	[mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
771	\| `INC `A ->
772	[mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
773	\| `INC (`REG(r1,r2,r3)) ->
774	[mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
775	\| `INC (`DIRECT b1) ->
776	[mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
777	\| `INC (`INDIRECT i1) ->
778	[mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
779	\| `INC `DPTR ->
780	[mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
781	\| `JB (`BIT b1, `REL b2) ->
782	[mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
783	\| `JBC (`BIT b1, `REL b2) ->
784	[mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
785	\| `JC (`REL b1) ->
786	[mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
787	\| `JMP `IND_DPTR ->
788	[mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
789	\| `JNB (`BIT b1, `REL b2) ->
790	[mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
791	\| `JNC (`REL b1) ->
792	[mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
793	\| `JNZ (`REL b1) ->
794	[mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
795	\| `JZ (`REL b1) ->
796	[mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
797	\| `LCALL (`ADDR16 w) ->
798	let (b1,b2) = from_word w in
799	[mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
800	\| `LJMP (`ADDR16 w) ->
801	let (b1,b2) = from_word w in
802	[mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
803	\| `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
804	[mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
805	\| `MOV (`U1 (`A, `DIRECT b1)) ->
806	[mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
807	\| `MOV (`U1 (`A, `INDIRECT i1)) ->
808	[mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
809	\| `MOV (`U1 (`A, `DATA b1)) ->
810	[mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
811	\| `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
812	[mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
813	\| `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
814	[mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
815	\| `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
816	[mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
817	\| `MOV (`U3 (`DIRECT b1, `A)) ->
818	[mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
819	\| `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
820	[mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
821	\| `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
822	[mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
823	\| `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
824	[mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
825	\| `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
826	[mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
827	\| `MOV (`U2 (`INDIRECT i1, `A)) ->
828	[mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
829	\| `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
830	[mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
831	\| `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
832	[mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
833	\| `MOV (`U5 (`C, `BIT b1)) ->
834	[mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
835	\| `MOV (`U6 (`BIT b1, `C)) ->
836	[mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
837	\| `MOV (`U4 (`DPTR, `DATA16 w)) ->
838	let (b1,b2) = from_word w in
839	[mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
840	\| `MOVC (`A, `A_DPTR) ->
841	[mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
842	\| `MOVC (`A, `A_PC) ->
843	[mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
844	\| `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
845	[mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
846	\| `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
847	[mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
848	\| `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
849	[mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
850	\| `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
851	[mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
852	\| `MUL(`A, `B) ->
853	[mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
854	\| `NOP ->
855	[mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
856	\| `ORL (`U1(`A, `REG(r1,r2,r3))) ->
857	[mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
858	\| `ORL (`U1(`A, `DIRECT b1)) ->
859	[mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
860	\| `ORL (`U1(`A, `INDIRECT i1)) ->
861	[mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
862	\| `ORL (`U1(`A, `DATA b1)) ->
863	[mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
864	\| `ORL (`U2(`DIRECT b1, `A)) ->
865	[mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
866	\| `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
867	[mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
868	\| `ORL (`U3 (`C, `BIT b1)) ->
869	[mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
870	\| `ORL (`U3 (`C, `NBIT b1)) ->
871	[mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
872	\| `POP (`DIRECT b1) ->
873	[mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
874	\| `PUSH (`DIRECT b1) ->
875	[mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
876	\| `RET ->
877	[mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
878	\| `RETI ->
879	[mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
880	\| `RL `A ->
881	[mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
882	\| `RLC `A ->
883	[mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
884	\| `RR `A ->
885	[mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
886	\| `RRC `A ->
887	[mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
888	\| `SETB `C ->
889	[mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
890	\| `SETB (`BIT b1) ->
891	[mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
892	\| `SJMP (`REL b1) ->
893	[mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
894	\| `SUBB (`A, `REG(r1,r2,r3)) ->
895	[mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
896	\| `SUBB (`A, `DIRECT b1) ->
897	[mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
898	\| `SUBB (`A, `INDIRECT i1) ->
899	[mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
900	\| `SUBB (`A, `DATA b1) ->
901	[mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
902	\| `SWAP `A ->
903	[mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
904	\| `XCH (`A, `REG(r1,r2,r3)) ->
905	[mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
906	\| `XCH (`A, `DIRECT b1) ->
907	[mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
908	\| `XCH (`A, `INDIRECT i1) ->
909	[mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
910	\| `XCHD(`A, `INDIRECT i1) ->
911	[mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
912	\| `XRL(`U1(`A, `REG(r1,r2,r3))) ->
913	[mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
914	\| `XRL(`U1(`A, `DIRECT b1)) ->
915	[mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
916	\| `XRL(`U1(`A, `INDIRECT i1)) ->
917	[mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
918	\| `XRL(`U1(`A, `DATA b1)) ->
919	[mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
920	\| `XRL(`U2(`DIRECT b1, `A)) ->
921	[mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
922	\| `XRL(`U2(`DIRECT b1, `DATA b2)) ->
923	[mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
924	;;
925
926	let load_code_memory = MiscPottier.foldi (fun i mem v -> Physical.WordMap.add (vect_of_int i `Sixteen) v mem) Physical.WordMap.empty
927
928	let load_mem mem status = { status with code_memory = mem }
929	let load l = load_mem (load_code_memory l)
930
931	let assembly_jump addr_of =
932	function
933	`JC a1 -> `JC (addr_of a1)
934	\| `JNC a1 -> `JNC (addr_of a1)
935	\| `JB (a1,a2) -> `JB (a1,addr_of a2)
936	\| `JNB (a1,a2) -> `JNB (a1,addr_of a2)
937	\| `JBC (a1,a2) -> `JBC (a1,addr_of a2)
938	\| `JZ a1 -> `JZ (addr_of a1)
939	\| `JNZ a1 -> `JNZ (addr_of a1)
940	\| `CJNE (a1,a2) -> `CJNE (a1,addr_of a2)
941	\| `DJNZ (a1,a2) -> `DJNZ (a1,addr_of a2)
942	;;
943
944	let assembly p =
945	let datalabels,_ =
946	List.fold_left
947	(fun (datalabels,addr) (name,size) ->
948	let addr16 = vect_of_int addr `Sixteen in
949	StringTools.Map.add name addr16 datalabels, addr+size
950	) (StringTools.Map.empty,0) p.ASM.ppreamble
951	in
952	let pc,exit_addr,labels,costs =
953	List.fold_left
954	(fun (pc,exit_addr,labels,costs) i ->
955	match i with
956	`Label s when s = p.ASM.pexit_label -> pc, pc, StringTools.Map.add s pc labels, costs
957	\| `Label s -> pc, exit_addr, StringTools.Map.add s pc labels, costs
958	\| `Cost s -> pc, exit_addr, labels, BitVectors.WordMap.add pc s costs
959	\| `Mov (_,_) -> (snd (half_add pc (vect_of_int 1 `Sixteen))), exit_addr, labels, costs
960	\| `Jmp _
961	\| `Call _ -> (snd (half_add pc (BitVectors.vect_of_int 3 `Sixteen))), exit_addr, labels, costs
962	(CSC: very stupid: always expand to worst opcode )
963	\| `WithLabel i ->
964	let fake_addr _ = `REL (zero `Eight) in
965	let fake_jump = assembly_jump fake_addr i in
966	let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
967	assert (fake_jump = i');
968	let pc' = snd (half_add pc' (vect_of_int 5 `Sixteen)) in
969	(snd (half_add pc pc'), exit_addr, labels, costs)
970	\| #instruction as i ->
971	let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
972	assert (i = i');
973	(snd (half_add pc pc'),exit_addr,labels, costs)
974	)
975	(BitVectors.zero `Sixteen,BitVectors.zero `Sixteen,
976	StringTools.Map.empty, BitVectors.WordMap.empty) p.ASM.pcode
977	in
978	let code =
979	List.flatten (List.map
980	(function
981	`Label _
982	\| `Cost _ -> []
983	\| `WithLabel i ->
984	(* We need to expand a conditional jump to a label to a machine language
985	conditional jump. Suppose we have:
986	JC label
987	This should be expanded to:
988	JC 2 -- size of a short jump
989	SJMP 3 -- size of a long jump
990	LJMP offset -- offset = position of label in code
991	And, for ever label appearing after the location of the jump in code
992	memory, we must increment by 5, as we added two new instructions. *)
993	let offset, jmp_address, translated_jump =
994	match i with
995	`JC (`Label a) ->
996	let address = StringTools.Map.find a labels in
997	let reconstructed = `JC (`REL (vect_of_int 2 `Eight)) in
998	5, address, reconstructed
999	\| `JNC (`Label a) ->
1000	let address = StringTools.Map.find a labels in
1001	let reconstructed = `JNC (`REL (vect_of_int 2 `Eight)) in
1002	5, address, reconstructed
1003	\| `JB (b, `Label a) ->
1004	let address = StringTools.Map.find a labels in
1005	let reconstructed = `JB (b, `REL (vect_of_int 2 `Eight)) in
1006	5, address, reconstructed
1007	\| `JNB (b, `Label a) ->
1008	let address = StringTools.Map.find a labels in
1009	let reconstructed = `JNB (b, `REL (vect_of_int 2 `Eight)) in
1010	5, address, reconstructed
1011	\| `JBC (b, `Label a) ->
1012	let address = StringTools.Map.find a labels in
1013	let reconstructed = `JBC (b, `REL (vect_of_int 2 `Eight)) in
1014	5, address, reconstructed
1015	\| `JZ (`Label a) ->
1016	let address = StringTools.Map.find a labels in
1017	let reconstructed = `JZ (`REL (vect_of_int 2 `Eight)) in
1018	5, address, reconstructed
1019	\| `JNZ (`Label a) ->
1020	let address = StringTools.Map.find a labels in
1021	let reconstructed = `JNZ (`REL (vect_of_int 2 `Eight)) in
1022	5, address, reconstructed
1023	\| `CJNE (args, `Label a) ->
1024	let address = StringTools.Map.find a labels in
1025	let reconstructed = `CJNE (args, `REL (vect_of_int 2 `Eight)) in
1026	5, address, reconstructed
1027	\| `DJNZ (args, `Label a) ->
1028	let address = StringTools.Map.find a labels in
1029	let reconstructed = `DJNZ (args, `REL (vect_of_int 2 `Eight)) in
1030	5, address, reconstructed
1031	in
1032	let sjmp, jmp = `SJMP (`REL (vect_of_int 3 `Eight)), `LJMP (`ADDR16 jmp_address) in
1033	let translation = [ translated_jump; sjmp; jmp ] in
1034	List.flatten (List.map assembly1 translation)
1035	\| `Mov (`DPTR,s) ->
1036	let addrr16 = StringTools.Map.find s datalabels in
1037	assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
1038	\| `Jmp s ->
1039	let pc_offset = StringTools.Map.find s labels in
1040	assembly1 (`LJMP (`ADDR16 pc_offset))
1041	\| `Call s ->
1042	let pc_offset = StringTools.Map.find s labels in
1043	assembly1 (`LCALL (`ADDR16 pc_offset ))
1044	\| #instruction as i -> assembly1 i) p.ASM.pcode) in
1045	{ ASM.code = code ; ASM.cost_labels = costs ;
1046	ASM.exit_addr = exit_addr ; ASM.has_main = p.ASM.phas_main }
1047	;;
1048
1049	let set_register status v reg =
1050	let addr = get_address_of_register status reg in
1051	{ status with low_internal_ram =
1052	Byte7Map.add addr v status.low_internal_ram }
1053	;;
1054
1055	let get_arg_8 status from_latch =
1056	function
1057	`DIRECT addr ->
1058	let n0, n1 = from_byte addr in
1059	(match from_nibble n0 with
1060	(false,r1,r2,r3) ->
1061	Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
1062	\| _ -> get_sfr status addr from_latch)
1063	\| `INDIRECT b ->
1064	let (b1, b2) = from_byte (get_register status (false,false,b)) in
1065	(match (from_nibble b1, b2) with
1066	(false,r1,r2,r3),b2 ->
1067	Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
1068	\| (true,r1,r2,r3),b2 ->
1069	Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
1070	\| `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
1071	\| `A -> status.acc
1072	\| `B -> status.b
1073	\| `DATA b -> b
1074	\| `A_DPTR ->
1075	let dpr = mk_word status.dph status.dpl in
1076	(* CSC: what is the right behaviour in case of overflow?
1077	assert false for now. Try to understand what DEC really does *)
1078	let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
1079	Physical.WordMap.find addr status.external_ram
1080	\| `A_PC ->
1081	(* CSC: what is the right behaviour in case of overflow?
1082	assert false for now *)
1083	let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
1084	Physical.WordMap.find addr status.external_ram
1085	\| `EXT_INDIRECT b ->
1086	let addr = get_register status (false,false,b) in
1087	Physical.WordMap.find (mk_word (zero `Eight) addr) status.external_ram
1088	\| `EXT_IND_DPTR ->
1089	let dpr = mk_word status.dph status.dpl in
1090	Physical.WordMap.find dpr status.external_ram
1091	;;
1092
1093	let get_arg_16 _status = function `DATA16 w -> w
1094
1095	let get_arg_1 status from_latch =
1096	function
1097	`BIT addr
1098	\| `NBIT addr as x ->
1099	let n1, n2 = from_byte addr in
1100	let res =
1101	(match from_nibble n1 with
1102	(false,r1,r2,r3) ->
1103	let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1104	let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1105	get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1106	\| (true,r1,r2,r3) ->
1107	let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1108	let div = addr / 8 in
1109	let rem = addr mod 8 in
1110	get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1111	in (match x with `NBIT _ -> not res \| _ -> res)
1112	\| `C -> get_cy_flag status
1113
1114	let set_arg_1 status v =
1115	function
1116	`BIT addr ->
1117	let n1, n2 = from_byte addr in
1118	(match from_nibble n1 with
1119	(false,r1,r2,r3) ->
1120	let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1121	let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1122	let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1123	{ status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1124	\| (true,r1,r2,r3) ->
1125	let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1126	let div = addr / 8 in
1127	let rem = addr mod 8 in
1128	let addr' = vect_of_int ((div * 8) + 128) `Eight in
1129	let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1130	let sfr' = set_bit sfr rem v in
1131	set_sfr status addr' sfr')
1132	\| `C ->
1133	let (n1,n2) = from_byte status.psw in
1134	let (_,b2,b3,b4) = from_nibble n1 in
1135	{ status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1136
1137	let set_arg_8 status v =
1138	function
1139	`DIRECT addr ->
1140	let (b1, b2) = from_byte addr in
1141	(match from_nibble b1 with
1142	(false,r1,r2,r3) ->
1143	{ status with low_internal_ram =
1144	Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1145	\| _ -> set_sfr status addr v)
1146	\| `INDIRECT b ->
1147	let (b1, b2) = from_byte (get_register status (false,false,b)) in
1148	(match (from_nibble b1, b2) with
1149	(false,r1,r2,r3),n1 ->
1150	{ status with low_internal_ram =
1151	Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1152	\| (true,r1,r2,r3),n1 ->
1153	{ status with high_internal_ram =
1154	Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1155	\| `REG (b1,b2,b3) ->
1156	set_register status v (b1,b2,b3)
1157	\| `A -> { status with acc = v }
1158	\| `B -> { status with b = v }
1159	\| `EXT_IND_DPTR ->
1160	let dpr = mk_word status.dph status.dpl in
1161	{ status with external_ram =
1162	Physical.WordMap.add dpr v status.external_ram }
1163	\| `EXT_INDIRECT b ->
1164	let addr = get_register status (false,false,b) in
1165	{ status with external_ram =
1166	Physical.WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1167	;;
1168
1169	let set_arg_16 status wrd =
1170	function
1171	`DPTR ->
1172	let (dh, dl) = from_word wrd in
1173	{ status with dph = dh; dpl = dl }
1174
1175	let set_flags status c ac ov =
1176	{ status with psw =
1177	let bu,bl = from_byte status.psw in
1178	let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1179	let ac = match ac with None -> oac \| Some v -> v in
1180	mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1181	}
1182	;;
1183
1184	let xor b1 b2 =
1185	if b1 = true && b2 = true then
1186	false
1187	else if b1 = false && b2 = false then
1188	false
1189	else true
1190	;;
1191
1192	let read_at_sp status =
1193	let n1,n2 = from_byte status.sp in
1194	let m,r1,r2,r3 = from_nibble n1 in
1195	Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1196	(if m then status.low_internal_ram else status.high_internal_ram)
1197	;;
1198
1199	let write_at_sp status v =
1200	let n1,n2 = from_byte status.sp in
1201	match from_nibble n1 with
1202	true,r1,r2,r3 ->
1203	let memory =
1204	Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1205	in
1206	{ status with low_internal_ram = memory }
1207	\| false,r1,r2,r3 ->
1208	let memory =
1209	Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1210	in
1211	{ status with high_internal_ram = memory }
1212	;;
1213
1214	let timer0 status b1 b2 ticks =
1215	let b = get_bit status.tcon 4 in
1216	(* Timer0 first *)
1217	(match b1,b2 with
1218	true,true ->
1219	(* Archaic 13 bit mode. *)
1220	if b then
1221	let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1222	let res = int_of_vect res in
1223	if res > 31 then
1224	let res = res mod 32 in
1225	let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1226	if ov' then
1227	let b = set_bit status.tcon 7 true in
1228	{ status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1229	else
1230	{ status with th0 = res'; tl0 = vect_of_int res `Eight }
1231	else
1232	{ status with tl0 = vect_of_int res `Eight }
1233	else
1234	status
1235	\| false,false ->
1236	(* 8 bit split timer mode. *)
1237	let status =
1238	(if b then
1239	let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1240	if ov then
1241	let b = set_bit status.tcon 5 true in
1242	{ status with tcon = b; tl0 = res }
1243	else
1244	{ status with tl0 = res }
1245	else
1246	status)
1247	in
1248	if get_bit status.tcon 6 then
1249	let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1250	if ov then
1251	let b = set_bit status.tcon 7 true in
1252	{ status with tcon = b; th0 = res }
1253	else
1254	{ status with th0 = res }
1255	else
1256	status
1257	\| false,true ->
1258	(* 16 bit timer mode. *)
1259	if b then
1260	let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1261	if ov then
1262	let b = set_bit status.tcon 5 true in
1263	let new_th0,new_tl0 = from_word res in
1264	{ status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1265	else
1266	let new_th0,new_tl0 = from_word res in
1267	{ status with th0 = new_th0; tl0 = new_tl0 }
1268	else
1269	status
1270	\| true,false ->
1271	(* 8 bit single timer mode. *)
1272	if b then
1273	let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1274	if ov then
1275	let b = set_bit status.tcon 5 true in
1276	{ status with tcon = b; tl0 = status.th0; }
1277	else
1278	{ status with tl0 = res }
1279	else
1280	status)
1281
1282	let timer1 status b3 b4 ticks =
1283	let b = get_bit status.tcon 4 in
1284	(match b3,b4 with
1285	true,true ->
1286	(* Archaic 13 bit mode. *)
1287	if b then
1288	let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1289	let res = int_of_vect res in
1290	if res > 31 then
1291	let res = res mod 32 in
1292	let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1293	if ov' then
1294	let b = set_bit status.tcon 7 true in
1295	{ status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1296	else
1297	{ status with th1 = res'; tl0 = vect_of_int res `Eight }
1298	else
1299	{ status with tl1 = vect_of_int res `Eight }
1300	else
1301	status
1302	\| false,false ->
1303	(* 8 bit split timer mode. *)
1304	let status =
1305	(if b then
1306	let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1307	if ov then
1308	let b = set_bit status.tcon 5 true in
1309	{ status with tcon = b; tl1 = res }
1310	else
1311	{ status with tl1 = res }
1312	else
1313	status)
1314	in
1315	if get_bit status.tcon 6 then
1316	let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1317	if ov then
1318	let b = set_bit status.tcon 7 true in
1319	{ status with tcon = b; th1 = res }
1320	else
1321	{ status with th1 = res }
1322	else
1323	status
1324	\| false,true ->
1325	(* 16 bit timer mode. *)
1326	if b then
1327	let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1328	if ov then
1329	let b = set_bit status.tcon 5 true in
1330	let new_th1,new_tl1 = from_word res in
1331	{ status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1332	else
1333	let new_th1,new_tl1 = from_word res in
1334	{ status with th1 = new_th1; tl1 = new_tl1 }
1335	else
1336	status
1337	\| true,false ->
1338	(* 8 bit single timer mode. *)
1339	if b then
1340	let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1341	if ov then
1342	let b = set_bit status.tcon 5 true in
1343	{ status with tcon = b; tl1 = status.th1; }
1344	else
1345	{ status with tl1 = res }
1346	else
1347	status)
1348	;;
1349
1350	let timers status ticks =
1351	(* DPM: Clock/Timer code follows. *)
1352	match bits_of_byte status.tmod with
1353	\| (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1354	let status =
1355	(if g0 then
1356	if get_bit status.p3 2 then
1357	if c0 then
1358	if status.previous_p1_val && not $ get_bit status.p3 4 then
1359	timer0 status b1 b2 ticks
1360	else
1361	status
1362	else
1363	timer0 status b1 b2 ticks
1364	else
1365	status
1366	else
1367	timer0 status b1 b2 ticks) in
1368	(* Timer 1 follows. *)
1369	let status =
1370	(if g1 then
1371	if get_bit status.p1 3 then
1372	if c1 then
1373	if status.previous_p3_val && not $ get_bit status.p3 5 then
1374	timer1 status b3 b4 ticks
1375	else
1376	status
1377	else
1378	timer1 status b3 b4 ticks
1379	else
1380	status
1381	else
1382	timer1 status b3 b4 ticks) in
1383	(* Timer 2 follows *)
1384	let status =
1385	(let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in
1386	(* Timer2 is enabled *)
1387	if tr2 then
1388	(* Counter/interval mode *)
1389	if ct2 && not cp2 then
1390	let word = mk_word status.th2 status.tl2 in
1391	let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in
1392	if ov then
1393	let new_th2 = status.rcap2h in
1394	let new_tl2 = status.rcap2l in
1395	(* Overflow flag not set if either of the following flags are set *)
1396	if not rclk && not tclk then
1397	let b = set_bit status.t2con 7 true in
1398	{ status with t2con = b;
1399	th2 = new_th2;
1400	tl2 = new_tl2 }
1401	else
1402	{ status with th2 = new_th2;
1403	tl2 = new_tl2 }
1404	else
1405	(* Reload also signalled when a 1-0 transition is detected *)
1406	if status.previous_p1_val && not $ get_bit status.p1 1 then
1407	(* In which case signal reload by setting T2CON.6 *)
1408	let b = set_bit status.t2con 6 true in
1409	{ status with th2 = status.rcap2h;
1410	tl2 = status.rcap2l;
1411	t2con = b }
1412	else
1413	let new_th2, new_tl2 = from_word res in
1414	{ status with th2 = new_th2;
1415	tl2 = new_tl2 }
1416	(* Capture mode *)
1417	else if cp2 && exen2 then
1418	(* 1-0 transition detected *)
1419	(* DPM: look at this: is the timer still running throughout? *)
1420	if status.previous_p1_val && not $ get_bit status.p1 1 then
1421	status (* Implement clock here *)
1422	else
1423	status (* Implement clock here *)
1424	else
1425	status
1426	else
1427	status) in status
1428
1429	;;
1430
1431	let serial_port_input status in_cont =
1432	(* Serial port input *)
1433	match in_cont with
1434	Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1435	(let status =
1436	(match line with
1437	`P1 b ->
1438	if status.clock >= time then
1439	{ status with p1 = b; p1_latch = b; }
1440	else
1441	status
1442	\| `P3 b ->
1443	if status.clock >= time then
1444	{ status with p3 = b; p3_latch = b; }
1445	else
1446	status
1447	\| `SerialBuff (`Eight b) ->
1448	let sm0 = get_bit status.scon 7 in
1449	let sm1 = get_bit status.scon 6 in
1450	(match (sm0, sm1) with
1451	(false, false) ->
1452	(* Mode 0: shift register. No delay. *)
1453	if status.clock >= time then
1454	{ status with scon = set_bit status.scon 0 true;
1455	io = cont;
1456	sbuf = b }
1457	else
1458	status
1459	\| (false, true) ->
1460	(* Mode 1: 8-bit UART *)
1461	(* Explanation: 8 bit asynchronous communication. There's a delay (epsilon)
1462	which needs taking care of. If we're trying to communicate at the same time
1463	an existing communication is occurring, we assert false (else clause of first
1464	if). *)
1465	if status.serial_epsilon_in = None && status.serial_v_in = None then
1466	if status.clock >= time then
1467	(* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1468	if get_bit status.scon 5 then
1469	assert false (* really: crash! *)
1470	else
1471	{ status with serial_epsilon_in = Some (epsilon + time);
1472	serial_v_in = Some (`Eight b) }
1473	else
1474	(* Warning about incomplete case analysis here, but safe as we've already tested for
1475	None. *)
1476	let Some e = status.serial_epsilon_in in
1477	let Some v = status.serial_v_in in
1478	if status.clock >= e then
1479	match v with
1480	`Eight v' ->
1481	{ status with sbuf = v';
1482	serial_v_in = None;
1483	serial_epsilon_in = None;
1484	scon = set_bit status.scon 0 true;
1485	io = cont }
1486	\| _ -> assert false (* trying to read in 9 bits instead of 8 *)
1487	else
1488	status
1489	else
1490	assert false
1491	\| (true, false) \| (true, true) ->
1492	assert false (* only got eight bits on the line when in 9 bit mode *))
1493	\| `SerialBuff (`Nine (b,b')) ->
1494	let sm0 = get_bit status.scon 7 in
1495	let sm1 = get_bit status.scon 6 in
1496	match(sm0, sm1) with
1497	(false, false) \| (false, true) -> assert false
1498	\| (true, false) \| (true, true) ->
1499	(* Modes 2 and 3: 9-bit UART *)
1500	(* Explanation: 9 bit asynchronous communication. There's a delay (epsilon)
1501	which needs taking care of. If we're trying to communicate at the same time
1502	an existing communication is occurring, we assert false (else claus of first
1503	if). *)
1504	if status.serial_epsilon_in = None && status.serial_v_in = None then
1505	if status.clock >= time then
1506	(* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1507	if get_bit status.scon 5 then
1508	assert false (* really: crash! *)
1509	else
1510	{ status with serial_epsilon_in = Some (epsilon + time);
1511	serial_v_in = Some (`Nine (b, b')) }
1512	else
1513	(* Warning about incomplete case analysis here, but safe as we've already tested for
1514	None. *)
1515	let Some e = status.serial_epsilon_in in
1516	let Some v = status.serial_v_in in
1517	if status.clock >= e then
1518	match v with
1519	`Nine (v, v') ->
1520	let scon' = set_bit status.scon 0 true in
1521	{ status with sbuf = v';
1522	serial_v_in = None;
1523	serial_epsilon_in = None;
1524	scon = set_bit scon' 2 b;
1525	io = cont }
1526	\| _ -> assert false (* trying to read in 8 bits instead of 9 *)
1527	else
1528	status
1529	else
1530	assert false)
1531	in
1532	{ status with io = cont })
1533	\| _ -> status
1534	;;
1535
1536	let serial_port_output status out_cont =
1537	(* Serial port output *)
1538	(let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1539	serial_v_out = Some (`Eight status.sbuf);
1540	serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1541	match status.serial_epsilon_out with
1542	Some s ->
1543	if status.clock >= s then
1544	match status.serial_k_out with
1545	None -> assert false (* correct? *)
1546	\| Some k' -> { status with io = k';
1547	scon = set_bit status.scon 1 true; }
1548	else
1549	status
1550	\| _ -> assert false)
1551	;;
1552
1553	let external_serial_interrupt status esi =
1554	(* Interrupt enabled *)
1555	if esi then
1556	(* If we're already running, then fine (todo: check for another interrupt
1557	and add to a queue, or something? *)
1558	if status.t1i_running then
1559	status
1560	else
1561	(* If we should be running, but aren't... *)
1562	if false then
1563	assert false
1564	else
1565	status
1566	else
1567	status
1568	;;
1569
1570	let external0_interrupt status e0i =
1571	(* Interrupt enabled *)
1572	if e0i then
1573	(* If we're already running, then fine (todo: check for another interrupt
1574	and add to a queue, or something? *)
1575	if status.t1i_running then
1576	status
1577	else
1578	(* If we should be running, but aren't... *)
1579	if false then
1580	assert false
1581	else
1582	status
1583	else
1584	status
1585	;;
1586
1587	let external1_interrupt status e1i =
1588	(* Interrupt enabled *)
1589	if e1i then
1590	(* If we're already running, then fine (todo: check for another interrupt
1591	and add to a queue, or something? *)
1592	if status.t1i_running then
1593	status
1594	else
1595	(* If we should be running, but aren't... *)
1596	if false then
1597	assert false
1598	else
1599	status
1600	else
1601	status
1602	;;
1603
1604	let timer0_interrupt status t0i =
1605	(* Interrupt enabled *)
1606	if t0i then
1607	(* If we're already running, then fine (todo: check for another interrupt
1608	and add to a queue, or something? *)
1609	if status.t1i_running then
1610	status
1611	else
1612	(* If we should be running, but aren't... *)
1613	if false then
1614	assert false
1615	else
1616	status
1617	else
1618	status
1619	;;
1620
1621	let timer1_interrupt status t1i =
1622	(* Interrupt enabled *)
1623	if t1i then
1624	(* If we're already running, then fine (todo: check for another interrupt
1625	and add to a queue, or something? *)
1626	if status.t1i_running then
1627	status
1628	else
1629	(* If we should be running, but aren't... *)
1630	if false then
1631	assert false
1632	else
1633	status
1634	else
1635	status
1636	;;
1637
1638	let interrupts status =
1639	let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1640	let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1641	(* DPM: are interrupts enabled? *)
1642	if ea then
1643	match (ps,pt1,px1,pt0,px0) with
1644	_ -> assert false
1645	else
1646	status
1647	;;
1648
1649	let execute1 status =
1650	let instr,pc,ticks = fetch status.code_memory status.pc in
1651	let status = { status with clock = status.clock + ticks; pc = pc } in
1652	let status =
1653	(match instr with
1654	`ADD (`A,d1) ->
1655	let v,c,ac,ov =
1656	add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1657	in
1658	set_flags (set_arg_8 status v `A) c (Some ac) ov
1659	\| `ADDC (`A,d1) ->
1660	let v,c,ac,ov =
1661	add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1662	in
1663	set_flags (set_arg_8 status v `A) c (Some ac) ov
1664	\| `SUBB (`A,d1) ->
1665	let v,c,ac,ov =
1666	subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1667	in
1668	set_flags (set_arg_8 status v `A) c (Some ac) ov
1669	\| `INC `DPTR ->
1670	let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1671	let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1672	{ status with dpl = low_order_byte; dph = high_order_byte }
1673	\| `INC ((`A \| `REG _ \| `DIRECT _ \| `INDIRECT _) as d) ->
1674	let b = get_arg_8 status true d in
1675	let cry, res = half_add b (vect_of_int 1 `Eight) in
1676	set_arg_8 status res d
1677	\| `DEC d ->
1678	let b = get_arg_8 status true d in
1679	let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1680	set_arg_8 status res d
1681	\| `MUL (`A,`B) ->
1682	let acc = int_of_vect status.acc in
1683	let b = int_of_vect status.b in
1684	let prod = acc * b in
1685	let ov = prod > 255 in
1686	let l = vect_of_int (prod mod 256) `Eight in
1687	let h = vect_of_int (prod / 256) `Eight in
1688	let status = { status with acc = l ; b = h } in
1689	(* DPM: Carry flag is always cleared. *)
1690	set_flags status false None ov
1691	\| `DIV (`A,`B) ->
1692	let acc = int_of_vect status.acc in
1693	let b = int_of_vect status.b in
1694	if b = 0 then
1695	(* CSC: ACC and B undefined! We leave them as they are. *)
1696	set_flags status false None true
1697	else
1698	let q = vect_of_int (acc / b) `Eight in
1699	let r = vect_of_int (acc mod b) `Eight in
1700	let status = { status with acc = q ; b = r } in
1701	set_flags status false None false
1702	\| `DA `A ->
1703	let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1704	if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1705	let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1706	let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1707	if int_of_vect acc_upper_nibble > 9 or cy = true then
1708	let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1709	let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1710	set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1711	else
1712	status
1713	else
1714	status
1715	\| `ANL (`U1(`A, ag)) ->
1716	let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1717	set_arg_8 status and_val `A
1718	\| `ANL (`U2((`DIRECT d), ag)) ->
1719	let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1720	set_arg_8 status and_val (`DIRECT d)
1721	\| `ANL (`U3 (`C, b)) ->
1722	let and_val = get_cy_flag status && get_arg_1 status true b in
1723	set_flags status and_val None (get_ov_flag status)
1724	\| `ORL (`U1(`A, ag)) ->
1725	let or_val = get_arg_8 status true `A -\|- get_arg_8 status true ag in
1726	set_arg_8 status or_val `A
1727	\| `ORL (`U2((`DIRECT d), ag)) ->
1728	let or_val = get_arg_8 status true (`DIRECT d) -\|- get_arg_8 status true ag in
1729	set_arg_8 status or_val (`DIRECT d)
1730	\| `ORL (`U3 (`C, b)) ->
1731	let or_val = get_cy_flag status \|\| get_arg_1 status true b in
1732	set_flags status or_val None (get_ov_flag status)
1733	\| `XRL (`U1(`A, ag)) ->
1734	let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1735	set_arg_8 status xor_val `A
1736	\| `XRL (`U2((`DIRECT d), ag)) ->
1737	let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1738	set_arg_8 status xor_val (`DIRECT d)
1739	\| `CLR `A -> set_arg_8 status (zero `Eight) `A
1740	\| `CLR `C -> set_arg_1 status false `C
1741	\| `CLR ((`BIT _) as a) -> set_arg_1 status false a
1742	\| `CPL `A -> { status with acc = complement status.acc }
1743	\| `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1744	\| `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1745	\| `RL `A -> { status with acc = rotate_left status.acc }
1746	\| `RLC `A ->
1747	let old_cy = get_cy_flag status in
1748	let n1, n2 = from_byte status.acc in
1749	let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1750	let status = set_arg_1 status b1 `C in
1751	{ status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1752	\| `RR `A -> { status with acc = rotate_right status.acc }
1753	\| `RRC `A ->
1754	let old_cy = get_cy_flag status in
1755	let n1, n2 = from_byte status.acc in
1756	let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1757	let status = set_arg_1 status b8 `C in
1758	{ status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1759	\| `SWAP `A ->
1760	let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1761	{ status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1762	\| `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1763	\| `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1764	\| `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1765	\| `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1766	\| `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1767	\| `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1768	\| `MOVC (`A, `A_DPTR) ->
1769	let big_acc = mk_word (zero `Eight) status.acc in
1770	let dptr = mk_word status.dph status.dpl in
1771	let cry, addr = half_add dptr big_acc in
1772	let lookup = Physical.WordMap.find addr status.code_memory in
1773	{ status with acc = lookup }
1774	\| `MOVC (`A, `A_PC) ->
1775	let big_acc = mk_word (zero `Eight) status.acc in
1776	(* DPM: Under specified: does the carry from PC incrementation affect the *)
1777	(* addition of the PC with the DPTR? At the moment, no. *)
1778	let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1779	let status = { status with pc = inc_pc } in
1780	let cry,addr = half_add inc_pc big_acc in
1781	let lookup = Physical.WordMap.find addr status.code_memory in
1782	{ status with acc = lookup }
1783	(* data transfer *)
1784	(* DPM: MOVX currently only implements the copying of data! *)
1785	\| `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1786	\| `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1787	\| `SETB b -> set_arg_1 status true b
1788	\| `PUSH a ->
1789	(* DPM: What happens if we overflow? *)
1790	let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1791	let status = { status with sp = new_sp } in
1792	write_at_sp status (get_arg_8 status false a)
1793	\| `POP (`DIRECT b) ->
1794	let contents = read_at_sp status in
1795	let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1796	let status = { status with sp = new_sp } in
1797	let status = set_arg_8 status contents (`DIRECT b) in
1798	status
1799	\| `XCH(`A, arg) ->
1800	let old_arg = get_arg_8 status false arg in
1801	let old_acc = status.acc in
1802	let status = set_arg_8 status old_acc arg in
1803	{ status with acc = old_arg }
1804	\| `XCHD(`A, i) ->
1805	let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1806	let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1807	let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1808	let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1809	let status = { status with acc = new_acc } in
1810	set_arg_8 status new_reg i
1811	(* program branching *)
1812	\| `JC (`REL rel) ->
1813	if get_cy_flag status then
1814	let cry, new_pc = half_add status.pc (sign_extension rel) in
1815	{ status with pc = new_pc }
1816	else
1817	status
1818	\| `JNC (`REL rel) ->
1819	if not $ get_cy_flag status then
1820	let cry, new_pc = half_add status.pc (sign_extension rel) in
1821	{ status with pc = new_pc }
1822	else
1823	status
1824	\| `JB (b, (`REL rel)) ->
1825	if get_arg_1 status false b then
1826	let cry, new_pc = half_add status.pc (sign_extension rel) in
1827	{ status with pc = new_pc }
1828	else
1829	status
1830	\| `JNB (b, (`REL rel)) ->
1831	if not $ get_arg_1 status false b then
1832	let cry, new_pc = half_add status.pc (sign_extension rel) in
1833	{ status with pc = new_pc }
1834	else
1835	status
1836	\| `JBC (b, (`REL rel)) ->
1837	let status = set_arg_1 status false b in
1838	if get_arg_1 status false b then
1839	let cry, new_pc = half_add status.pc (sign_extension rel) in
1840	{ status with pc = new_pc }
1841	else
1842	status
1843	\| `RET ->
1844	(* DPM: What happens when we underflow? *)
1845	let high_bits = read_at_sp status in
1846	let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1847	let status = { status with sp = new_sp } in
1848	let low_bits = read_at_sp status in
1849	let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1850	let status = { status with sp = new_sp } in
1851	{ status with pc = mk_word high_bits low_bits }
1852	\| `RETI ->
1853	let high_bits = read_at_sp status in
1854	let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1855	let status = { status with sp = new_sp } in
1856	let low_bits = read_at_sp status in
1857	let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1858	let status = { status with sp = new_sp } in
1859	{ status with pc = mk_word high_bits low_bits }
1860	\| `ACALL (`ADDR11 a) ->
1861	let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1862	let status = { status with sp = new_sp } in
1863	let pc_upper_byte, pc_lower_byte = from_word status.pc in
1864	let status = write_at_sp status pc_lower_byte in
1865	let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1866	let status = { status with sp = new_sp } in
1867	let status = write_at_sp status pc_upper_byte in
1868	let addr = addr16_of_addr11 status.pc a in
1869	{ status with pc = addr }
1870	\| `LCALL (`ADDR16 addr) ->
1871	let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1872	let status = { status with sp = new_sp } in
1873	let pc_upper_byte, pc_lower_byte = from_word status.pc in
1874	let status = write_at_sp status pc_lower_byte in
1875	let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1876	let status = { status with sp = new_sp } in
1877	let status = write_at_sp status pc_upper_byte in
1878	{ status with pc = addr }
1879	\| `AJMP (`ADDR11 a) ->
1880	let addr = addr16_of_addr11 status.pc a in
1881	{ status with pc = addr }
1882	\| `LJMP (`ADDR16 a) ->
1883	{ status with pc = a }
1884	\| `SJMP (`REL rel) ->
1885	let cry, new_pc = half_add status.pc (sign_extension rel) in
1886	{ status with pc = new_pc }
1887	\| `JMP `IND_DPTR ->
1888	let dptr = mk_word status.dph status.dpl in
1889	let big_acc = mk_word (zero `Eight) status.acc in
1890	let cry, jmp_addr = half_add big_acc dptr in
1891	let cry, new_pc = half_add status.pc jmp_addr in
1892	{ status with pc = new_pc }
1893	\| `JZ (`REL rel) ->
1894	if status.acc = zero `Eight then
1895	let cry, new_pc = half_add status.pc (sign_extension rel) in
1896	{ status with pc = new_pc }
1897	else
1898	status
1899	\| `JNZ (`REL rel) ->
1900	if status.acc <> zero `Eight then
1901	let cry, new_pc = half_add status.pc (sign_extension rel) in
1902	{ status with pc = new_pc }
1903	else
1904	status
1905	\| `CJNE ((`U1 (`A, ag)), `REL rel) ->
1906	let new_carry = status.acc < get_arg_8 status false ag in
1907	if get_arg_8 status false ag <> status.acc then
1908	let cry, new_pc = half_add status.pc (sign_extension rel) in
1909	let status = set_flags status new_carry None (get_ov_flag status) in
1910	{ status with pc = new_pc; }
1911	else
1912	set_flags status new_carry None (get_ov_flag status)
1913	\| `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1914	let new_carry = get_arg_8 status false ag < d in
1915	if get_arg_8 status false ag <> d then
1916	let cry, new_pc = half_add status.pc (sign_extension rel) in
1917	let status = { status with pc = new_pc } in
1918	set_flags status new_carry None (get_ov_flag status)
1919	else
1920	set_flags status new_carry None (get_ov_flag status)
1921	\| `DJNZ (ag, (`REL rel)) ->
1922	let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1923	let status = set_arg_8 status new_ag ag in
1924	if new_ag <> zero `Eight then
1925	let cry, new_pc = half_add status.pc (sign_extension rel) in
1926	{ status with pc = new_pc }
1927	else
1928	status
1929	\| `NOP -> status) in
1930	let status = timers status ticks in
1931	let in_cont, `Out out_cont = status.io in
1932	let status = serial_port_input status in_cont in
1933	let status = serial_port_output status out_cont in
1934	let status = interrupts status in
1935	{ status with previous_p1_val = get_bit status.p3 4;
1936	previous_p3_val = get_bit status.p3 5 }
1937	;;
1938
1939	(*
1940	OLD output routine:
1941	(* Serial port output, part one *)
1942	let status =
1943	(match status.expected_out_time with
1944	`At t when status.clock >= t ->
1945	{ status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1946	\| _ -> status) in
1947
1948	(if status.expected_out_time = `Now then
1949	if get_bit status.scon 7 then
1950	let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1951	{ status with expected_out_time = `At exp_time; io = new_cont }
1952	else
1953	let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1954	{ status with expected_out_time = `At exp_time; io = new_cont }
1955	else
1956	status) in
1957	*)
1958
1959	let rec execute f s =
1960	let cont =
1961	try f s; true
1962	with Halt -> false
1963	in
1964	if cont then execute f (execute1 s)
1965	else s
1966	;;
1967
1968
1969	let load_program p =
1970	let st = load p.ASM.code initialize in
1971	{ st with exit_addr = p.ASM.exit_addr ; cost_labels = p.ASM.cost_labels }
1972
1973	let observe_trace trace_ref st =
1974	let cost_label =
1975	if BitVectors.WordMap.mem st.pc st.cost_labels then
1976	[BitVectors.WordMap.find st.pc st.cost_labels]
1977	else [] in
1978	trace_ref := cost_label @ !trace_ref ;
1979	if st.pc = st.exit_addr (* <=> end of program *) then raise Halt else st
1980
1981	let result st =
1982	let i = BitVectors.int_of_vect st.dpl in
1983	IntValue.Int8.of_int i
1984
1985	let interpret print_result p =
1986	if p.ASM.has_main then
1987	let st = load_program p in
1988	let trace = ref [] in
1989	let callback = observe_trace trace in
1990	let st = execute callback st in
1991	let res = result st in
1992	if print_result then
1993	Printf.printf "8051: %s\n%!" (IntValue.Int8.to_string res) ;
1994	(res, List.rev !trace)
1995	else (IntValue.Int8.zero, [])

Note: See TracBrowser for help on using the repository browser.

Download in other formats: