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

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

IntelHex? file modified: string_of_intel_hex_entry implemented.

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