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

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

Fixed weird type errors in ASMInterpret.

File size: 48.2 KB
Line 
1open BitVectors;;
2open Physical;;
3open ASM;;
4
5exception Fetch_exception of string;;
6exception CodeTooLarge;;
7exception Halt;;
8
9type time = int;;
10
11(* no differentiation between internal and external code memory *)
12type status =
13 { code_memory: WordMap.map;        (* can be reduced *)
14   low_internal_ram: Byte7Map.map;
15   high_internal_ram: Byte7Map.map;
16   external_ram: WordMap.map;
17
18   pc: word;
19
20   (* sfr *)
21   p0: byte;
22   sp: byte;
23   dpl: byte;
24   dph: byte;
25   pcon: byte;
26   tcon: byte;
27   tmod: byte;
28   tl0: byte;
29   tl1: byte;
30   th0: byte;
31   th1: byte;
32   p1: byte;
33   scon: byte;
34   sbuf: byte;
35   p2: byte;
36   ie: byte;
37   p3: byte;
38   ip: byte;
39   psw: byte;
40   acc: byte;
41   b: byte;
42
43   clock: time;
44   timer0: word;
45   timer1: word;
46   timer2: word;  (* can be missing *)
47   io: time * int -> byte option
48 }
49
50let initialize = {
51  code_memory = WordMap.empty;
52  low_internal_ram = Byte7Map.empty;
53  high_internal_ram = Byte7Map.empty;
54  external_ram = WordMap.empty;
55
56  pc = zero `Sixteen;
57
58  p0 = zero `Eight;
59  sp = vect_of_int 7 `Eight;
60  dpl = zero `Eight;
61  dph = zero `Eight;
62  pcon = zero `Eight;
63  tcon = zero `Eight;
64  tmod = zero `Eight;
65  tl0 = zero `Eight;
66  tl1 = zero `Eight;
67  th0 = zero `Eight;
68  th1 = zero `Eight;
69  p1 = zero `Eight;
70  scon = zero `Eight;
71  sbuf = zero `Eight;
72  p2 = zero `Eight;
73  ie = zero `Eight;
74  p3 = zero `Eight;
75  ip = zero `Eight;
76  psw = zero `Eight;
77  acc = zero `Eight;
78  b = zero `Eight;
79  clock = 0;
80  timer0 = zero `Sixteen;
81  timer1 = zero `Sixteen;
82  timer2 = zero `Sixteen;
83
84  io = (fun (time, line) -> None)
85}
86
87let get_cy_flag status =
88  let (cy,_,_,_),(_,_,_,_) = bits_of_byte status.psw in cy
89let get_ac_flag status =
90  let (_,ac,_,_),(_,_,_,_) = bits_of_byte status.psw in ac
91let get_fo_flag status =
92  let (_,_,fo,_),(_,_,_,_) = bits_of_byte status.psw in fo
93let get_rs1_flag status =
94  let (_,_,_,rs1),(_,_,_,_) = bits_of_byte status.psw in rs1
95let get_rs0_flag status =
96  let (_,_,_,_),(rs0,_,_,_) = bits_of_byte status.psw in rs0
97let get_ov_flag status =
98  let (_,_,_,_),(_,ov,_,_) = bits_of_byte status.psw in ov
99let get_ud_flag status =
100  let (_,_,_,_),(_,_,ud,_) = bits_of_byte status.psw in ud
101let get_p_flag status =
102  let (_,_,_,_),(_,_,_,p) = bits_of_byte status.psw in p
103
104(* timings taken from SIEMENS *)
105
106let fetch pmem pc =
107 let next pc =
108   let (carry, res) = half_add pc (vect_of_int 1 `Sixteen) in
109     res, WordMap.find pc pmem
110 in
111 let instr = WordMap.find pc pmem in
112 let cy, pc = half_add pc (vect_of_int 1 `Sixteen) in
113 let (un, ln) = from_byte instr in
114 let bits = (from_nibble un, from_nibble ln) in
115  match bits with
116     (a10,a9,a8,true),(false,false,false,true) ->
117      let pc,b1 = next pc in
118       `ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
119   | (false,false,true,false),(true,r1,r2,r3) ->
120      `ADD (`A,`REG (r1,r2,r3)), pc, 1
121   | (false,false,true,false),(false,true,false,true) ->
122      let pc,b1 = next pc in
123       `ADD (`A,`DIRECT b1), pc, 1
124   | (false,false,true,false),(false,true,true,i1) ->
125       `ADD (`A,`INDIRECT i1), pc, 1
126   | (false,false,true,false),(false,true,false,false) ->
127      let pc,b1 = next pc in
128       `ADD (`A,`DATA b1), pc, 1
129   | (false,false,true,true),(true,r1,r2,r3) ->
130       `ADDC (`A,`REG (r1,r2,r3)), pc, 1
131   | (false,false,true,true),(false,true,false,true) ->
132      let pc,b1 = next pc in
133       `ADDC (`A,`DIRECT b1), pc, 1
134   | (false,false,true,true),(false,true,true,i1) ->
135       `ADDC (`A,`INDIRECT i1), pc, 1
136   | (false,false,true,true),(false,true,false,false) ->
137      let pc,b1 = next pc in
138       `ADDC (`A,`DATA b1), pc, 1
139   | (a10,a9,a8,false),(false,false,false,true) ->
140      let pc,b1 = next pc in
141       `AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
142   | (false,true,false,true),(true,r1,r2,r3) ->
143      `ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1
144   | (false,true,false,true),(false,true,false,true) ->
145      let pc,b1 = next pc in
146       `ANL (`U1 (`A, `DIRECT b1)), pc, 1
147   | (false,true,false,true),(false,true,true,i1) ->
148       `ANL (`U1 (`A, `INDIRECT i1)), pc, 1
149   | (false,true,false,true),(false,true,false,false) ->
150      let pc,b1 = next pc in
151       `ANL (`U1 (`A, `DATA b1)), pc, 1
152   | (false,true,false,true),(false,false,true,false) ->
153      let pc,b1 = next pc in
154       `ANL (`U2 (`DIRECT b1,`A)), pc, 1
155   | (false,true,false,true),(false,false,true,true) ->
156      let pc,b1 = next pc in
157      let pc,b2 = next pc in
158       `ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2
159   | (true,false,false,false),(false,false,true,false) ->
160      let pc,b1 = next pc in
161       `ANL (`U3 (`C,`BIT b1)), pc, 2
162   | (true,false,true,true),(false,false,false,false) ->
163      let pc,b1 = next pc in
164       `ANL (`U3 (`C,`NBIT b1)), pc, 2
165   | (true,false,true,true),(false,true,false,true) ->
166      let       pc,b1 = next pc in
167      let pc,b2 = next pc in
168        `CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2
169   | (true,false,true,true),(false,true,false,false) ->
170       let pc,b1 = next pc in
171       let pc,b2 = next pc in
172         `CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2
173   | (true,false,true,true),(true,r1,r2,r3) ->
174       let pc,b1 = next pc in
175       let pc,b2 = next pc in
176         `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2
177   | (true,false,true,true),(false,true,true,i1) ->
178       let pc,b1 = next pc in
179       let pc,b2 = next pc in
180         `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2
181   | (true,true,true,false),(false,true,false,false) ->
182         `CLR `A, pc, 1
183   | (true,true,false,false),(false,false,true,true) ->
184         `CLR `C, pc, 1
185   | (true,true,false,false),(false,false,true,false) ->
186       let pc,b1 = next pc in
187         `CLR (`BIT b1), pc, 1
188   | (true,true,true,true),(false,true,false,false) ->
189         `CPL `A, pc, 1
190   | (true,false,true,true),(false,false,true,true) ->
191         `CPL `C, pc, 1
192   | (true,false,true,true),(false,false,true,false) ->
193       let pc,b1 = next pc in
194         `CPL (`BIT b1), pc, 1
195   | (true,true,false,true),(false,true,false,false) ->
196         `DA `A, pc, 1
197   | (false,false,false,true),(false,true,false,false) ->
198         `DEC `A, pc, 1
199   | (false,false,false,true),(true,r1,r2,r3) ->
200         `DEC (`REG(r1,r2,r3)), pc, 1
201   | (false,false,false,true),(false,true,false,true) ->
202       let pc,b1 = next pc in
203         `DEC (`DIRECT b1), pc, 1
204   | (false,false,false,true),(false,true,true,i1) ->
205         `DEC (`INDIRECT i1), pc, 1
206   | (true,false,false,false),(false,true,false,false) ->
207         `DIV (`A, `B), pc, 4
208   | (true,true,false,true),(true,r1,r2,r3) ->
209       let pc,b1 = next pc in
210         `DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2
211   | (true,true,false,true),(false,true,false,true) ->
212       let pc,b1 = next pc in
213       let pc,b2 = next pc in
214         `DJNZ (`DIRECT b1, `REL b2), pc, 2
215   | (false,false,false,false),(false,true,false,false) ->
216         `INC `A, pc, 1
217   | (false,false,false,false),(true,r1,r2,r3) ->
218         `INC (`REG(r1,r2,r3)), pc, 1
219   | (false,false,false,false),(false,true,false,true) ->
220       let pc,b1 = next pc in
221         `INC (`DIRECT b1), pc, 1
222   | (false,false,false,false),(false,true,true,i1) ->
223         `INC (`INDIRECT i1), pc, 1
224   | (true,false,true,false),(false,false,true,true) ->
225         `INC `DPTR, pc, 2
226   | (false,false,true,false),(false,false,false,false) ->
227       let pc,b1 = next pc in
228       let pc,b2 = next pc in
229         `JB (`BIT b1, `REL b2), pc, 2
230   | (false,false,false,true),(false,false,false,false) ->
231       let pc,b1 = next pc in
232       let pc,b2 = next pc in
233         `JBC (`BIT b1, `REL b2), pc, 2
234   | (false,true,false,false),(false,false,false,false) ->
235       let pc,b1 = next pc in
236         `JC (`REL b1), pc, 2
237   | (false,true,true,true),(false,false,true,true) ->
238         `JMP `IND_DPTR, pc, 2
239   | (false,false,true,true),(false,false,false,false) ->
240       let pc,b1 = next pc in
241       let pc,b2 = next pc in
242         `JNB (`BIT b1, `REL b2), pc, 2
243   | (false,true,false,true),(false,false,false,false) ->
244       let pc,b1 = next pc in
245         `JNC (`REL b1), pc, 2
246   | (false,true,true,true),(false,false,false,false) ->
247       let pc,b1 = next pc in
248         `JNZ (`REL b1), pc, 2
249   | (false,true,true,false),(false,false,false,false) ->
250       let pc,b1 = next pc in
251         `JZ (`REL b1), pc, 2
252   | (false,false,false,true),(false,false,true,false) ->
253       let pc,b1 = next pc in
254       let pc,b2 = next pc in
255         `LCALL (`ADDR16 (mk_word b1 b2)), pc, 2
256   | (false,false,false,false),(false,false,true,false) ->
257       let pc,b1 = next pc in
258       let pc,b2 = next pc in
259         `LJMP (`ADDR16 (mk_word b1 b2)), pc, 2
260   | (true,true,true,false),(true,r1,r2,r3) ->
261         `MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1
262   | (true,true,true,false),(false,true,false,true) ->
263       let pc,b1 = next pc in
264         `MOV (`U1 (`A, `DIRECT b1)), pc, 1
265   | (true,true,true,false),(false,true,true,i1) ->
266         `MOV (`U1 (`A, `INDIRECT i1)), pc, 1
267   | (false,true,true,true),(false,true,false,false) ->
268       let pc,b1 = next pc in
269         `MOV (`U1 (`A, `DATA b1)), pc, 1
270   | (true,true,true,true),(true,r1,r2,r3) ->
271         `MOV (`U2 (`REG(r1,r2,r3), `A)), pc, 1
272   | (true,false,true,false),(true,r1,r2,r3) ->
273       let pc,b1 = next pc in
274         `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))), pc, 2
275   | (false,true,true,true),(true,r1,r2,r3) ->
276       let pc,b1 = next pc in
277         `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))), pc, 1
278   | (true,true,true,true),(false,true,false,true) ->
279       let pc,b1 = next pc in
280         `MOV (`U3 (`DIRECT b1, `A)), pc, 1
281   | (true,false,false,false),(true,r1,r2,r3) ->
282       let pc,b1 = next pc in
283         `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))), pc, 2
284   | (true,false,false,false),(false,true,false,true) ->
285       let pc,b1 = next pc in
286       let pc,b2 = next pc in
287         `MOV (`U3 (`DIRECT b1, `DIRECT b2)), pc, 2
288   | (true,false,false,false),(false,true,true,i1) ->
289       let pc,b1 = next pc in
290         `MOV (`U3 (`DIRECT b1, `INDIRECT i1)), pc, 2
291   | (false,true,true,true),(false,true,false,true) ->
292       let pc,b1 = next pc in
293       let pc,b2 = next pc in
294         `MOV (`U3 (`DIRECT b1, `DATA b2)), pc, 2
295   | (true,true,true,true),(false,true,true,i1) ->
296         `MOV (`U2 (`INDIRECT i1, `A)), pc, 1
297   | (true,false,true,false),(false,true,true,i1) ->
298       let pc,b1 = next pc in
299         `MOV (`U2 (`INDIRECT i1, `DIRECT b1)), pc, 2
300   | (false,true,true,true),(false,true,true,i1) ->
301       let pc,b1 = next pc in
302         `MOV (`U2 (`INDIRECT i1, `DATA b1)), pc, 1
303   | (true,false,true,false),(false,false,true,false) ->
304       let pc,b1 = next pc in
305         `MOV (`U5 (`C, `BIT b1)), pc, 1
306   | (true,false,false,true),(false,false,true,false) ->
307       let pc,b1 = next pc in
308         `MOV (`U6 (`BIT b1, `C)), pc, 2
309   | (true,false,false,true),(false,false,false,false) ->
310       let pc,b1 = next pc in
311       let pc,b2 = next pc in
312         `MOV (`U4 (`DPTR, `DATA16(mk_word b1 b2))), pc, 2
313   | (true,false,false,true),(false,false,true,true) ->
314         `MOVC (`A, `A_DPTR), pc, 2
315   | (true,false,false,false),(false,false,true,true) ->
316         `MOVC (`A, `A_PC), pc, 2
317   | (true,true,true,false),(false,false,true,i1) ->
318         `MOVX (`U1 (`A, `EXT_INDIRECT i1)), pc, 2
319   | (true,true,true,false),(false,false,false,false) ->
320         `MOVX (`U1 (`A, `EXT_IND_DPTR)), pc, 2
321   | (true,true,true,true),(false,false,true,i1) ->
322         `MOVX (`U2 (`EXT_INDIRECT i1, `A)), pc, 2
323   | (true,true,true,true),(false,false,false,false) ->
324         `MOVX (`U2 (`EXT_IND_DPTR, `A)), pc, 2
325   | (true,false,true,false),(false,true,false,false) ->
326         `MUL(`A, `B), pc, 4
327   | (false,false,false,false),(false,false,false,false) ->
328         `NOP, pc, 1
329   | (false,true,false,false),(true,r1,r2,r3) ->
330         `ORL (`U1(`A, `REG(r1,r2,r3))), pc, 1
331   | (false,true,false,false),(false,true,false,true) ->
332       let pc,b1 = next pc in
333         `ORL (`U1(`A, `DIRECT b1)), pc, 1
334   | (false,true,false,false),(false,true,true,i1) ->
335         `ORL (`U1(`A, `INDIRECT i1)), pc, 1
336   | (false,true,false,false),(false,true,false,false) ->
337       let pc,b1 = next pc in
338         `ORL (`U1(`A, `DATA b1)), pc, 1
339   | (false,true,false,false),(false,false,true,false) ->
340       let pc,b1 = next pc in
341         `ORL (`U2(`DIRECT b1, `A)), pc, 1
342   | (false,true,false,false),(false,false,true,true) ->
343       let pc,b1 = next pc in
344       let pc,b2 = next pc in
345         `ORL (`U2 (`DIRECT b1, `DATA b2)), pc, 2
346   | (false,true,true,true),(false,false,true,false) ->
347       let pc,b1 = next pc in
348         `ORL (`U3 (`C, `BIT b1)), pc, 2
349   | (true,false,true,false),(false,false,false,false) ->
350       let pc,b1 = next pc in
351         `ORL (`U3 (`C, `NBIT b1)), pc, 2
352   | (true,true,false,true),(false,false,false,false) ->
353       let pc,b1 = next pc in
354         `POP (`DIRECT b1), pc, 2
355   | (true,true,false,false),(false,false,false,false) ->
356       let pc,b1 = next pc in
357         `PUSH (`DIRECT b1), pc, 2
358   | (false,false,true,false),(false,false,true,false) ->
359         `RET, pc, 2
360   | (false,false,true,true),(false,false,true,false) ->
361         `RETI, pc, 2
362   | (false,false,true,false),(false,false,true,true) ->
363         `RL `A, pc, 1
364   | (false,false,true,true),(false,false,true,true) ->
365         `RLC `A, pc, 1
366   | (false,false,false,false),(false,false,true,true) ->
367         `RR `A, pc, 1
368   | (false,false,false,true),(false,false,true,true) ->
369         `RRC `A, pc, 1
370   | (true,true,false,true),(false,false,true,true) ->
371         `SETB `C, pc, 1
372   | (true,true,false,true),(false,false,true,false) ->
373       let pc,b1 = next pc in
374         `SETB (`BIT b1), pc, 1
375   | (true,false,false,false),(false,false,false,false) ->
376       let pc,b1 = next pc in
377         `SJMP (`REL b1), pc, 2
378   | (true,false,false,true),(true,r1,r2,r3) ->
379       `SUBB (`A, `REG(r1,r2,r3)), pc, 1
380   | (true,false,false,true),(false,true,false,true) ->
381       let pc,b1 = next pc in
382         `SUBB (`A, `DIRECT b1), pc, 1
383   | (true,false,false,true),(false,true,true,i1) ->
384         `SUBB (`A, `INDIRECT i1), pc, 1
385   | (true,false,false,true),(false,true,false,false) ->
386       let pc,b1 = next pc in
387         `SUBB (`A, `DATA b1), pc, 1
388   | (true,true,false,false),(false,true,false,false) ->
389         `SWAP `A, pc, 1
390   | (true,true,false,false),(true,r1,r2,r3) ->
391         `XCH (`A, `REG(r1,r2,r3)), pc, 1
392   | (true,true,false,false),(false,true,false,true) ->
393       let pc,b1 = next pc in
394         `XCH (`A, `DIRECT b1), pc, 1
395   | (true,true,false,false),(false,true,true,i1) ->
396         `XCH (`A, `INDIRECT i1), pc, 1
397   | (true,true,false,true),(false,true,true,i1) ->
398         `XCHD(`A, `INDIRECT i1), pc, 1
399   | (false,true,true,false),(true,r1,r2,r3) ->
400         `XRL(`U1(`A, `REG(r1,r2,r3))), pc, 1
401   | (false,true,true,false),(false,true,false,true) ->
402       let pc,b1 = next pc in
403         `XRL(`U1(`A, `DIRECT b1)), pc, 1
404   | (false,true,true,false),(false,true,true,i1) ->
405         `XRL(`U1(`A, `INDIRECT i1)), pc, 1
406   | (false,true,true,false),(false,true,false,false) ->
407       let pc,b1 = next pc in
408         `XRL(`U1(`A, `DATA b1)), pc, 1
409   | (false,true,true,false),(false,false,true,false) ->
410       let pc,b1 = next pc in
411         `XRL(`U2(`DIRECT b1, `A)), pc, 1
412   | (false,true,true,false),(false,false,true,true) ->
413       let pc,b1 = next pc in
414       let pc,b2 = next pc in
415         `XRL(`U2(`DIRECT b1, `DATA b2)), pc, 2
416   | _,_ -> assert false
417;;
418
419let assembly1 =
420 function
421    `ACALL (`ADDR11 w) ->
422      let (a10,a9,a8,b1) = from_word11 w in
423        [mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
424  | `ADD (`A,`REG (r1,r2,r3)) ->
425     [mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
426  | `ADD (`A, `DIRECT b1) ->
427     [mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
428  | `ADD (`A, `INDIRECT i1) ->
429     [mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
430  | `ADD (`A, `DATA b1) ->
431     [mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
432  | `ADDC (`A, `REG(r1,r2,r3)) ->
433     [mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
434  | `ADDC (`A, `DIRECT b1) ->
435     [mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
436  | `ADDC (`A,`INDIRECT i1) ->
437     [mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
438  | `ADDC (`A,`DATA b1) ->
439     [mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
440  | `AJMP (`ADDR11 w) ->
441     let (a10,a9,a8,b1) = from_word11 w in
442       [mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true))]
443  | `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
444     [mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
445  | `ANL (`U1 (`A, `DIRECT b1)) ->
446     [mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
447  | `ANL (`U1 (`A, `INDIRECT i1)) ->
448     [mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
449  | `ANL (`U1 (`A, `DATA b1)) ->
450     [mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
451  | `ANL (`U2 (`DIRECT b1,`A)) ->
452     [mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
453  | `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
454     [mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
455  | `ANL (`U3 (`C,`BIT b1)) ->
456     [mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
457  | `ANL (`U3 (`C,`NBIT b1)) ->
458    [mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
459  | `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
460    [mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
461  | `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
462    [mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
463  | `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
464    [mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
465  | `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
466    [mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
467  | `CLR `A ->
468    [mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
469  | `CLR `C ->
470    [mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
471  | `CLR (`BIT b1) ->
472    [mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
473  | `CPL `A ->
474    [mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
475  | `CPL `C ->
476    [mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
477  | `CPL (`BIT b1) ->
478    [mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
479  | `DA `A ->
480    [mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
481  | `DEC `A ->
482    [mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
483  | `DEC (`REG(r1,r2,r3)) ->
484    [mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
485  | `DEC (`DIRECT b1) ->
486    [mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
487  | `DEC (`INDIRECT i1) ->
488    [mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
489  | `DIV (`A, `B) ->
490    [mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
491  | `DJNZ (`REG(r1,r2,r3), `REL b1) ->
492    [mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
493  | `DJNZ (`DIRECT b1, `REL b2) ->
494    [mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
495  | `INC `A ->
496    [mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
497  | `INC (`REG(r1,r2,r3)) ->
498    [mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
499  | `INC (`DIRECT b1) ->
500    [mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
501  | `INC (`INDIRECT i1) ->
502    [mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
503  | `INC `DPTR ->
504    [mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
505  | `JB (`BIT b1, `REL b2) ->
506    [mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
507  | `JBC (`BIT b1, `REL b2) ->
508    [mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
509  | `JC (`REL b1) ->
510    [mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
511  | `JMP `IND_DPTR ->
512    [mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
513  | `JNB (`BIT b1, `REL b2) ->
514    [mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
515  | `JNC (`REL b1) ->
516    [mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
517  | `JNZ (`REL b1) ->
518    [mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
519  | `JZ (`REL b1) ->
520    [mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
521  | `LCALL (`ADDR16 w) ->
522      let (b1,b2) = from_word w in
523        [mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
524  | `LJMP (`ADDR16 w) ->
525      let (b1,b2) = from_word w in
526        [mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
527  | `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
528    [mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
529  | `MOV (`U1 (`A, `DIRECT b1)) ->
530    [mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
531  | `MOV (`U1 (`A, `INDIRECT i1)) ->
532    [mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
533  | `MOV (`U1 (`A, `DATA b1)) ->
534    [mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
535  | `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
536    [mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
537  | `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
538    [mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
539  | `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
540    [mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
541  | `MOV (`U3 (`DIRECT b1, `A)) ->
542    [mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
543  | `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
544    [mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
545  | `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
546    [mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
547  | `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
548    [mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
549  | `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
550    [mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
551  | `MOV (`U2 (`INDIRECT i1, `A)) ->
552    [mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
553  | `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
554    [mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
555  | `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
556    [mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
557  | `MOV (`U5 (`C, `BIT b1)) ->
558    [mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
559  | `MOV (`U6 (`BIT b1, `C)) ->
560    [mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
561  | `MOV (`U4 (`DPTR, `DATA16 w)) ->
562    let (b1,b2) = from_word w in
563      [mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
564  | `MOVC (`A, `A_DPTR) ->
565    [mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
566  | `MOVC (`A, `A_PC) ->
567    [mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
568  | `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
569    [mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
570  | `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
571    [mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
572  | `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
573    [mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
574  | `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
575    [mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
576  | `MUL(`A, `B) ->
577    [mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
578  | `NOP ->
579    [mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
580  | `ORL (`U1(`A, `REG(r1,r2,r3))) ->
581    [mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
582  | `ORL (`U1(`A, `DIRECT b1)) ->
583    [mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
584  | `ORL (`U1(`A, `INDIRECT i1)) ->
585    [mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
586  | `ORL (`U1(`A, `DATA b1)) ->
587    [mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
588  | `ORL (`U2(`DIRECT b1, `A)) ->
589    [mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
590  | `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
591    [mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
592  | `ORL (`U3 (`C, `BIT b1)) ->
593    [mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
594  | `ORL (`U3 (`C, `NBIT b1)) ->
595    [mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
596  | `POP (`DIRECT b1) ->
597    [mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
598  | `PUSH (`DIRECT b1) ->
599    [mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
600  | `RET ->
601    [mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
602  | `RETI ->
603    [mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
604  | `RL `A ->
605    [mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
606  | `RLC `A ->
607    [mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
608  | `RR `A ->
609    [mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
610  | `RRC `A ->
611    [mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
612  | `SETB `C ->
613    [mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
614  | `SETB (`BIT b1) ->
615    [mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
616  | `SJMP (`REL b1) ->
617    [mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
618  | `SUBB (`A, `REG(r1,r2,r3)) ->
619    [mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
620  | `SUBB (`A, `DIRECT b1) ->
621    [mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
622  | `SUBB (`A, `INDIRECT i1) ->
623    [mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
624  | `SUBB (`A, `DATA b1) ->
625    [mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
626  | `SWAP `A ->
627    [mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
628  | `XCH (`A, `REG(r1,r2,r3)) ->
629    [mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
630  | `XCH (`A, `DIRECT b1) ->
631    [mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
632  | `XCH (`A, `INDIRECT i1) ->
633    [mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
634  | `XCHD(`A, `INDIRECT i1) ->
635    [mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
636  | `XRL(`U1(`A, `REG(r1,r2,r3))) ->
637    [mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
638  | `XRL(`U1(`A, `DIRECT b1)) ->
639    [mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
640  | `XRL(`U1(`A, `INDIRECT i1)) ->
641    [mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
642  | `XRL(`U1(`A, `DATA b1)) ->
643    [mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
644  | `XRL(`U2(`DIRECT b1, `A)) ->
645    [mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
646  | `XRL(`U2(`DIRECT b1, `DATA b2)) ->
647    [mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
648;;
649
650let fold_lefti f =
651 let rec aux i acc =
652  function
653     [] -> acc
654   | he::tl -> aux (i+1) (f i acc he) tl
655 in
656  aux 0
657;;
658
659let load_code_memory = fold_lefti (fun i mem v -> WordMap.add (vect_of_int i `Sixteen) v mem) WordMap.empty
660
661let load l status = { status with code_memory = load_code_memory l }
662
663module StringMap = Map.Make(String);;
664
665let assembly l =
666 let pc,labels,costs =
667  List.fold_left
668   (fun (pc,labels,costs) i ->
669     match i with
670        `Label s -> pc, StringMap.add s pc labels, costs
671      | `Cost s -> pc, labels, StringMap.add s pc costs
672      | `Jmp s
673      | `Call s -> pc + 3, labels, costs  (*CSC: very stupid: always expand to worst opcode *)
674      | #instruction as i ->
675        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
676         assert (i = i');
677         (pc + int_of_vect pc',labels, costs)
678   ) (0,StringMap.empty,StringMap.empty) l
679 in
680  if pc >= 65536 then
681   raise CodeTooLarge
682  else
683      List.flatten (List.map
684         (function
685            `Label s -> []
686          | `Cost s -> []
687          | `Jmp s ->
688              let pc_offset = StringMap.find s labels in
689                assembly1 (`LJMP (`ADDR16 (vect_of_int pc_offset `Sixteen)))
690          | `Call s ->
691              let pc_offset = StringMap.find s labels in
692                assembly1 (`LCALL (`ADDR16 (vect_of_int pc_offset `Sixteen)))
693          | #instruction as i -> assembly1 i) l)
694;;
695
696let get_address_of_register status (b1,b2,b3) =
697 let bu,bl = from_byte status.psw in
698 let (_,_,rs1,rs0) = from_nibble bu in
699 let base =
700  match rs1,rs0 with
701     false,false -> 0x00
702   | false,true  -> 0x08
703   | true,false  -> 0x10
704   | true,true   -> 0x18
705 in
706   vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven
707;;
708
709let get_register status reg =
710  let addr = get_address_of_register status reg in
711    Byte7Map.find addr status.low_internal_ram
712;;
713
714let set_register status v reg =
715  let addr = get_address_of_register status reg in
716    { status with low_internal_ram =
717        Byte7Map.add addr v status.low_internal_ram }
718;;
719
720let get_arg_8 status = 
721 function
722    `DIRECT addr ->
723       let n0, n1 = from_byte addr in
724       (match from_nibble n0 with
725          (false,r1,r2,r3) ->
726            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
727        | (true,r1,r2,r3) ->
728             (*CSC: SFR access, TO BE IMPLEMENTED *)
729            assert false)
730  | `INDIRECT b ->
731       let (b1, b2) = from_byte (get_register status (false,false,b)) in
732         (match (from_nibble b1, b2) with 
733           (false,r1,r2,r3),b2 ->
734             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
735         | (true,r1,r2,r3),b2 ->
736             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
737  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
738  | `A -> status.acc
739  | `B -> status.b
740  | `DATA b -> b
741  | `A_DPTR ->
742       let dpr = mk_word status.dph status.dpl in
743       (* CSC: what is the right behaviour in case of overflow?
744          assert false for now. Try to understand what DEC really does *)
745       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
746         WordMap.find addr status.external_ram
747  | `A_PC ->
748       (* CSC: what is the right behaviour in case of overflow?
749          assert false for now *)
750       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
751         WordMap.find addr status.external_ram
752  | `IND_DPTR ->
753       let dpr = mk_word status.dph status.dpl in
754         WordMap.find dpr status.external_ram
755;;
756
757let get_arg_16 status =
758  function
759                `DATA16 w -> w
760
761let get_arg_1 status =
762  function
763    `BIT addr
764  | `NBIT addr as x ->
765     let n1, n2 = from_byte addr in
766     let res =
767      (match from_nibble n1 with
768         (false,r1,r2,r3) ->
769           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
770           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
771           let bit = get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) in
772             (match bit with
773               None -> assert false
774             | Some bit' -> bit')
775        | (true,r1,r2,r3) ->
776           (*CSC: SFR access, TO BE IMPLEMENTED *)
777           assert false)
778    in (match x with `BIT _ -> res | _ -> not res)
779  | `C -> get_cy_flag status
780
781let set_arg_1 status v =
782  function
783    `BIT addr ->
784      let n1, n2 = from_byte addr in
785      (match from_nibble n1 with
786         (false,r1,r2,r3) ->
787           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
788           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
789           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
790             (match n_bit with
791                None -> assert false
792              | Some n_bit' ->
793                  { status with low_internal_ram = Byte7Map.add addr' n_bit' status.low_internal_ram })
794                        | (true,r1,r2,r3) ->
795           (*CSC: SFR access, TO BE IMPLEMENTED *)
796           (* assert false for now. Try to understand what DEC really does *)
797           assert false)
798    | `C ->
799       let (n1,n2) = from_byte status.psw in
800       let (_,b2,b3,b4) = from_nibble n1 in
801         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
802
803let set_arg_8 status v =
804 function
805    `DIRECT addr ->
806      let (b1, b2) = from_byte addr in
807      (match from_nibble b1 with
808         (false,r1,r2,r3) ->
809           { status with low_internal_ram =
810              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
811       | (true,r1,r2,r3) ->
812           (*CSC: SFR access, TO BE IMPLEMENTED *)
813           (* assert false for now. Try to understand what DEC really does *)
814           assert false)
815  | `INDIRECT b ->
816     let (b1, b2) = from_byte (get_register status (false,false,b)) in
817     (match (from_nibble b1, b2) with 
818         (false,r1,r2,r3),n1 ->
819           { status with low_internal_ram =
820              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
821       | (true,r1,r2,r3),n1 ->
822           { status with high_internal_ram =
823              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
824  | `REG (b1,b2,b3) ->
825      set_register status v (b1,b2,b3)
826  | `A -> { status with acc = v }
827  | `B -> { status with b = v }
828  | `IND_DPTR ->
829     let dpr = mk_word status.dph status.dpl in
830      { status with external_ram =
831        WordMap.add dpr v status.external_ram }
832;;
833
834let set_arg_16 status wrd =
835        function
836                `DPTR ->
837       let (dh, dl) = from_word wrd in
838         { status with dph = dh; dpl = dl }
839
840let set_flags status c ac ov =
841 { status with psw =
842    let bu,bl = from_byte status.psw in
843    let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
844    let ac = match ac with None -> oac | Some v -> v in
845      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
846 }
847;;
848
849let xor b1 b2 =
850  if b1 = true && b2 = true then
851    false
852  else if b1 = false && b2 = false then
853    false
854  else true
855;;
856
857let ($) f x = f x
858
859let execute1 status =
860 let instr,pc,ticks = fetch status.code_memory status.pc in
861 let status = { status with clock = status.clock + ticks; pc = pc } in
862  match instr with
863     `ADD (`A,d1) ->
864        let v,c,ac,ov =
865          add8_with_c (get_arg_8 status `A) (get_arg_8 status d1) false
866        in
867          set_flags (set_arg_8 status v `A) c (Some ac) ov
868   | `ADDC (`A,d1) ->
869        let v,c,ac,ov =
870          add8_with_c (get_arg_8 status `A) (get_arg_8 status d1) (get_cy_flag status)
871        in
872          set_flags (set_arg_8 status v `A) c (Some ac) ov
873   | `SUBB (`A,d1) ->
874        let v,c,ac,ov =
875          subb8_with_c (get_arg_8 status `A) (get_arg_8 status d1) (get_cy_flag status)
876        in
877          set_flags (set_arg_8 status v `A) c (Some ac) ov
878   | `INC `DPTR ->
879       let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
880       let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
881         { status with dpl = low_order_byte; dph = high_order_byte }
882   | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
883       let b = get_arg_8 status d in
884       let cry, res = half_add b (vect_of_int 0 `Eight) in
885         set_arg_8 status res d
886   | `DEC d ->
887       let b = get_arg_8 status d in
888       let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
889         set_arg_8 status res d
890   | `MUL (`A,`B) ->
891       let acc = int_of_vect status.acc in
892       let b = int_of_vect status.b in
893       let prod = acc * b in
894       let ov = prod > 255 in
895       let l = vect_of_int (prod  mod 256) `Eight in
896       let h = vect_of_int (prod / 256) `Eight in
897       let status = { status with acc = l ; b = h } in
898         (* DPM: Carry flag is always cleared. *)
899         set_flags status false None ov
900   | `DIV (`A,`B) ->
901      let acc = int_of_vect status.acc in
902      let b = int_of_vect status.b in
903      if b = 0 then
904        (* CSC: ACC and B undefined! We leave them as they are. *)
905        set_flags status false None true
906      else
907        let q = vect_of_int (acc / b) `Eight in
908        let r = vect_of_int (acc mod b) `Eight in
909        let status = { status with acc = q ; b = r } in
910          set_flags status false None false
911   | `DA `A ->
912        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
913          if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
914            let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
915            let acc_upper_nibble, acc_lower_nibble = from_byte acc in
916            if int_of_vect acc_upper_nibble > 9 or cy = true then
917              let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
918              let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
919                set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
920            else
921              status
922          else
923            status
924   | `ANL (`U1(`A, ag)) ->
925        let and_val = get_arg_8 status `A -&- get_arg_8 status ag in
926          set_arg_8 status and_val `A
927   | `ANL (`U2((`DIRECT d), ag)) ->
928        let and_val = get_arg_8 status (`DIRECT d) -&- get_arg_8 status ag in
929          set_arg_8 status and_val `A
930   | `ANL (`U3 (`C, b)) ->
931        let and_val = get_cy_flag status && get_arg_1 status b in
932          set_flags status and_val None (get_ov_flag status)
933   | `ORL (`U1(`A, ag)) ->
934        let or_val = get_arg_8 status `A -|- get_arg_8 status ag in
935          set_arg_8 status or_val `A
936   | `ORL (`U2((`DIRECT d), ag)) ->
937        let or_val = get_arg_8 status (`DIRECT d) -|- get_arg_8 status ag in
938          set_arg_8 status or_val `A
939   | `ORL (`U3 (`C, b)) ->
940        let or_val = get_cy_flag status || get_arg_1 status b in
941          set_flags status or_val None (get_ov_flag status)
942   | `XRL (`U1(`A, ag)) ->
943        let xor_val = get_arg_8 status `A -^- get_arg_8 status ag in
944          set_arg_8 status xor_val `A
945   | `XRL (`U2((`DIRECT d), ag)) ->
946        let xor_val = get_arg_8 status (`DIRECT d) -^- get_arg_8 status ag in
947          set_arg_8 status xor_val `A
948   | `CLR `A -> set_arg_8 status (zero `Eight) `A
949   | `CLR `C -> set_arg_1 status false `C
950   | `CLR ((`BIT b) as a) -> set_arg_1 status false a
951   | `CPL `A -> { status with acc = complement status.acc }
952   | `CPL `C -> set_arg_1 status (not $ get_arg_1 status `C) `C
953   | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status b) b
954   | `RL `A -> { status with acc = rotate_left status.acc }
955   | `RLC `A ->
956        let old_cy = get_cy_flag status in
957        let n1, n2 = from_byte status.acc in
958        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
959        let status = set_arg_1 status b1 `C in
960          { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
961   | `RR `A -> { status with acc = rotate_right status.acc }
962   | `RRC `A ->
963        let old_cy = get_cy_flag status in
964        let n1, n2 = from_byte status.acc in
965        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
966        let status = set_arg_1 status b8 `C in
967          { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
968   | `SWAP `A ->
969        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
970          { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
971  | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
972  | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
973  | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status b2) b1
974  | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
975  | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status b2) b1
976  | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status b2) b1
977  | `MOVC (`A, `A_DPTR) ->
978     let big_acc = mk_word (zero `Eight) status.acc in
979     let dptr = mk_word status.dph status.dpl in
980     let cry, addr = half_add dptr big_acc in
981     let lookup = WordMap.find addr status.code_memory in
982       { status with acc = lookup }
983  | `MOVC (`A, `A_PC) ->
984     let big_acc = mk_word (zero `Eight) status.acc in
985     (* DPM: Under specified: does the carry from PC incrementation affect the *)
986     (*      addition of the PC with the DPTR? At the moment, no.              *)
987     let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
988     let status = { status with pc = inc_pc } in
989     let cry,addr = half_add inc_pc big_acc in
990     let lookup = WordMap.find addr status.code_memory in
991       { status with acc = lookup }
992 (* data transfer *)
993(*
994 | MOVX of (acc * [ indirect | indirect_dptr ],
995            [ indirect | indirect_dptr ] * acc) union2
996*)
997  | `SETB b -> set_arg_1 status true b
998  | `PUSH (`DIRECT b) ->
999       (* DPM: What happens if we overflow? *)
1000       let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1001       let status = { status with sp = new_sp } in
1002       let memory = Byte7Map.add (byte7_of_byte status.sp) b status.low_internal_ram in
1003         { status with low_internal_ram = memory }
1004  | `POP (`DIRECT b) ->
1005       let contents = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1006       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1007       let status = { status with sp = new_sp } in
1008       let status = set_arg_8 status contents (`DIRECT b) in
1009         status
1010  | `XCH(`A, arg) ->
1011       let old_arg = get_arg_8 status arg in
1012       let old_acc = status.acc in
1013       let status = set_arg_8 status old_acc arg in
1014         { status with acc = old_arg }
1015  | `XCHD(`A, i) ->
1016       let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status `A in
1017       let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status i in
1018       let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1019       let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1020       let status = { status with acc = new_acc } in
1021         set_arg_8 status new_reg i
1022 (* program branching *)
1023  | `JC (`REL rel) ->
1024       if get_cy_flag status then
1025         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1026           { status with pc = new_pc }
1027       else
1028         status
1029  | `JNC (`REL rel) ->
1030       if not $ get_cy_flag status then
1031         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1032           { status with pc = new_pc }
1033       else
1034         status
1035  | `JB (b, (`REL rel)) ->
1036       if get_arg_1 status b then
1037         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1038           { status with pc = new_pc }
1039       else
1040         status
1041  | `JNB (b, (`REL rel)) ->
1042       if not $ get_arg_1 status b then
1043         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1044           { status with pc = new_pc }
1045       else
1046         status
1047  | `JBC (b, (`REL rel)) ->
1048       let status = set_arg_1 status false b in
1049         if get_arg_1 status b then
1050           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1051             { status with pc = new_pc }
1052         else
1053           status
1054  | `RET ->
1055      (* DPM: What happens when we underflow? *)
1056       let high_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1057       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1058       let status = { status with sp = new_sp } in
1059       let low_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1060       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1061       let status = { status with sp = new_sp } in
1062         { status with pc = mk_word high_bits low_bits }
1063  | `RETI ->
1064       let high_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1065       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1066       let status = { status with sp = new_sp } in
1067       let low_bits = Byte7Map.find (byte7_of_byte status.sp) status.low_internal_ram in
1068       let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1069       let status = { status with sp = new_sp } in
1070         { status with pc = mk_word high_bits low_bits }
1071  | `ACALL (`ADDR11 a) ->
1072       let cry, new_pc = half_add status.pc (vect_of_int 2 `Sixteen) in
1073       let status = { status with pc = new_pc } in
1074       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1075       let status = { status with sp = new_sp } in
1076       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1077       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_lower_byte status.low_internal_ram in
1078       let status = { status with low_internal_ram = lower_mem } in
1079       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1080       let status = { status with sp = new_sp } in
1081       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_upper_byte status.low_internal_ram in
1082       let status = { status with low_internal_ram = lower_mem } in
1083       let n1, n2 = from_byte pc_upper_byte in
1084       let (b1,b2,b3,b) = from_word11 a in
1085       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1086       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in
1087         { status with pc = addr }
1088  | `LCALL (`ADDR16 addr) ->
1089       let cry, new_pc = half_add status.pc (vect_of_int 3 `Sixteen) in
1090       let status = { status with pc = new_pc } in
1091       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1092       let status = { status with sp = new_sp } in
1093       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1094       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_upper_byte status.low_internal_ram in
1095       let status = { status with low_internal_ram = lower_mem } in
1096       let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1097       let status = { status with sp = new_sp } in
1098       let lower_mem = Byte7Map.add (byte7_of_byte status.sp) pc_lower_byte status.low_internal_ram in
1099       let status = { status with low_internal_ram = lower_mem } in
1100         { status with pc = addr }
1101  | `AJMP (`ADDR11 a) ->
1102       let cry, new_pc = half_add status.pc (vect_of_int 2 `Sixteen) in
1103       let status = { status with pc = new_pc } in
1104       let pc_upper_byte, pc_lower_byte = from_word status.pc in
1105       let n1, n2 = from_byte pc_upper_byte in
1106       let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in
1107       let (b1,b2,b3,b) = from_word11 a in
1108       let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in
1109       let cry, new_pc = half_add status.pc addr in
1110         { status with pc = new_pc }
1111  | `LJMP (`ADDR16 a) ->
1112       { status with pc = a }
1113  | `SJMP (`REL rel) ->
1114       let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1115         { status with pc = new_pc }
1116  | `JMP `IND_DPTR ->
1117       let dptr = mk_word status.dph status.dpl in
1118       let big_acc = mk_word (zero `Eight) status.acc in
1119       let cry, jmp_addr = half_add big_acc dptr in
1120       let cry, new_pc = half_add status.pc jmp_addr in
1121         { status with pc = new_pc }
1122  | `JZ (`REL rel) ->
1123       if status.acc = zero `Eight then
1124         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1125           { status with pc = new_pc }
1126       else
1127         status
1128  | `JNZ (`REL rel) ->
1129       if status.acc <> zero `Eight then
1130         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1131                           { status with pc = new_pc }
1132       else
1133         status
1134  | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1135       let new_carry = status.acc < get_arg_8 status ag in
1136         if get_arg_8 status ag <> status.acc then
1137           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1138           let status = set_flags status new_carry None (get_ov_flag status) in
1139             { status with pc = new_pc;  }
1140         else
1141           set_flags status new_carry None (get_ov_flag status)
1142  | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1143     let new_carry = get_arg_8 status ag < d in
1144       if get_arg_8 status ag <> d then
1145         let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1146         let status = { status with pc = new_pc } in
1147           set_flags status new_carry None (get_ov_flag status)
1148       else
1149         set_flags status new_carry None (get_ov_flag status)
1150  | `DJNZ (ag, (`REL rel)) ->
1151       let new_ag,_,_,_ = subb8_with_c (get_arg_8 status ag) (vect_of_int 1 `Eight) false in
1152       let status = set_arg_8 status new_ag ag in
1153         if new_ag <> zero `Eight then
1154           let cry, new_pc = half_add status.pc (mk_word (zero `Eight) rel) in
1155             { status with pc = new_pc }
1156         else
1157           status
1158  | `NOP -> status
1159  | _ -> assert false (* DPM: Until MOVX implemented. *)
1160;;
1161
1162let rec execute f s =
1163 let s = execute1 s in
1164 let cont =
1165  try f s; true
1166  with Halt -> false
1167 in
1168  if cont then execute f s
1169  else s
1170;;
Note: See TracBrowser for help on using the repository browser.