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

Last change on this file since 164 was 163, checked in by mulligan, 10 years ago

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