Changeset 440 for Deliverables/D4.1/ASMInterpret.ml
 Timestamp:
 Dec 16, 2010, 6:17:52 PM (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

Deliverables/D4.1/ASMInterpret.ml
r280 r440 18 18 let string_of_line = 19 19 function 20 21 22 23 24  `P3 b >25 26 27 28  `SerialBuff (`Eight b) >29 30 31 32  `SerialBuff (`Nine (b, b')) >33 34 35 36 37 38 39 40 20 `P1 b > 21 "========================\n" ^ 22 "P1 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^ 23 "========================\n" 24  `P3 b > 25 "========================\n" ^ 26 "P2 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^ 27 "========================\n" 28  `SerialBuff (`Eight b) > 29 "========================\n" ^ 30 "SERIAL 8b OUTPUT: " ^ string_of_vect b ^ "\n" ^ 31 "========================\n" 32  `SerialBuff (`Nine (b, b')) > 33 "========================\n" ^ 34 "SERIAL 9b OUTPUT: " ^ 35 (let i = int_of_vect b' in 36 if b then 37 string_of_int (128 + i) 38 else 39 string_of_int i) ^ 40 "========================\n" 41 41 42 42 (* In: reception time, line of input, new continuation, … … 49 49 type continuation = 50 50 [`In of time * line * epsilon * continuation] option * 51 [`Out of (time > line > time * continuation)]51 [`Out of (time > line > time * continuation)] 52 52 53 53 let rec debug_continuation = 54 (Some (`In (1, (`SerialBuff (`Eight (vect_of_int 5 `Eight))), 0, debug_continuation))), `Out (55 fun time line >56 let _ = prerr_endline <*> string_of_line $ line in54 (Some (`In (1, (`SerialBuff (`Eight (vect_of_int 5 `Eight))), 0, debug_continuation))), `Out ( 55 fun time line > 56 let _ = prerr_endline <*> string_of_line $ line in 57 57 (time + 1),debug_continuation) 58 58 59 59 (* no differentiation between internal and external code memory *) 60 60 type status = … … 135 135 (* Try to understand I/O *) 136 136 let get_sfr status addr from_latch = 137 match int_of_vect addr with 138 (* I/O and timer ports *) 139 0x80 > assert false (* P0 not modeled *) 140  0x90 > if from_latch then 141 status.p1_latch 142 else status.p1 143  0xA0 > assert false (* P2 not modeled *) 144  0xB0 > if from_latch then 145 status.p3_latch 146 else status.p3 147  0x99 > status.sbuf 148  0x8A > status.tl0 149  0x8B > status.tl1 150  0x8C > status.th0 151  0x8D > status.th1 152  0xC8 > status.t2con 153  0xCA > status.rcap2l 154  0xCB > status.rcap2h 155  0xCC > status.tl2 156  0xCD > status.th2 137 match int_of_vect addr with 138 (* I/O and timer ports *) 139 0x80 > assert false (* P0 not modeled *) 140  0x90 > 141 if from_latch then 142 status.p1_latch 143 else status.p1 144  0xA0 > assert false (* P2 not modeled *) 145  0xB0 > 146 if from_latch then 147 status.p3_latch 148 else status.p3 149  0x99 > status.sbuf 150  0x8A > status.tl0 151  0x8B > status.tl1 152  0x8C > status.th0 153  0x8D > status.th1 154  0xC8 > status.t2con 155  0xCA > status.rcap2l 156  0xCB > status.rcap2h 157  0xCC > status.tl2 158  0xCD > status.th2 157 159 158 160 (* control ports *) 159  0x87 > status.pcon160  0x88 > status.tcon161  0x89 > status.tmod162  0x98 > status.scon163  0xA8 > status.ie164  0xB8 > status.ip165 161  0x87 > status.pcon 162  0x88 > status.tcon 163  0x89 > status.tmod 164  0x98 > status.scon 165  0xA8 > status.ie 166  0xB8 > status.ip 167 166 168 (* registers *) 167  0x81 > status.sp168  0x82 > status.dpl169  0x83 > status.dph170  0xD0 > status.psw171  0xE0 > status.acc172  0xF0 > status.b173  _ > assert false169  0x81 > status.sp 170  0x82 > status.dpl 171  0x83 > status.dph 172  0xD0 > status.psw 173  0xE0 > status.acc 174  0xF0 > status.b 175  _ > assert false 174 176 ;; 175 177 176 178 (* Try to understand I/O *) 177 179 let set_sfr status addr v = 178 match int_of_vect addr with179 (* I/O and timer ports *)180 0x80 > assert false (* P0 not modeled *)181  0x90 > { status with p1 = v; p1_latch = v }182  0xA0 > assert false (* P2 not modeled *)183  0xB0 > { status with p3 = v; p3_latch = v }184  0x99 >180 match int_of_vect addr with 181 (* I/O and timer ports *) 182 0x80 > assert false (* P0 not modeled *) 183  0x90 > { status with p1 = v; p1_latch = v } 184  0xA0 > assert false (* P2 not modeled *) 185  0xB0 > { status with p3 = v; p3_latch = v } 186  0x99 > 185 187 if status.expected_out_time = `None then 186 188 { status with sbuf = v; expected_out_time = `Now } … … 188 190 (* a real assert false: trying to initiate a transmission whilst one is still active *) 189 191 assert false 190  0x8A > { status with tl0 = v }191  0x8B > { status with tl1 = v }192  0x8C > { status with th0 = v }193  0x8D > { status with th1 = v }194  0xC8 > { status with t2con = v }195  0xCA > { status with rcap2l = v }196  0xCB > { status with rcap2h = v }197  0xCD > { status with tl2 = v }198  0xCE > { status with th2 = v }199 200 (* control ports *)201  0x87 > { status with pcon = v }202  0x88 > { status with tcon = v }203  0x89 > { status with tmod = v }204  0x98 > { status with scon = v }205  0xA8 > { status with ie = v }206  0xB8 > { status with ip = v }207 208 (* registers *)209  0x81 > { status with sp = v }210  0x82 > { status with dpl = v }211  0x83 > { status with dph = v }212  0xD0 > { status with psw = v }213  0xE0 > { status with acc = v }214  0xF0 > { status with b = v }215  _ > assert false192  0x8A > { status with tl0 = v } 193  0x8B > { status with tl1 = v } 194  0x8C > { status with th0 = v } 195  0x8D > { status with th1 = v } 196  0xC8 > { status with t2con = v } 197  0xCA > { status with rcap2l = v } 198  0xCB > { status with rcap2h = v } 199  0xCD > { status with tl2 = v } 200  0xCE > { status with th2 = v } 201 202 (* control ports *) 203  0x87 > { status with pcon = v } 204  0x88 > { status with tcon = v } 205  0x89 > { status with tmod = v } 206  0x98 > { status with scon = v } 207  0xA8 > { status with ie = v } 208  0xB8 > { status with ip = v } 209 210 (* registers *) 211  0x81 > { status with sp = v } 212  0x82 > { status with dpl = v } 213  0x83 > { status with dph = v } 214  0xD0 > { status with psw = v } 215  0xE0 > { status with acc = v } 216  0xF0 > { status with b = v } 217  _ > assert false 216 218 ;; 217 219 … … 221 223 high_internal_ram = Byte7Map.empty; 222 224 external_ram = WordMap.empty; 223 225 224 226 pc = zero `Sixteen; 225 227 226 228 sp = vect_of_int 7 `Eight; 227 229 dpl = zero `Eight; … … 298 300 299 301 let get_address_of_register status (b1,b2,b3) = 300 let bu,_bl = from_byte status.psw in301 let (_,_,rs1,rs0) = from_nibble bu in302 let base =303 match rs1,rs0 with304 305  false,true > 0x08306  true,false > 0x10307  true,true > 0x18308 in309 302 let bu,_bl = from_byte status.psw in 303 let (_,_,rs1,rs0) = from_nibble bu in 304 let base = 305 match rs1,rs0 with 306 false,false > 0x00 307  false,true > 0x08 308  true,false > 0x10 309  true,true > 0x18 310 in 311 vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven 310 312 ;; 311 313 312 314 let get_register status reg = 313 315 let addr = get_address_of_register status reg in 314 316 Byte7Map.find addr status.low_internal_ram 315 317 ;; 316 318 … … 374 376 375 377 let fetch pmem pc = 376 let next pc =377 let _carry, res = half_add pc (vect_of_int 1 `Sixteen) in378 379 in380 let pc,instr = next pc in381 let un, ln = from_byte instr in382 let bits = (from_nibble un, from_nibble ln) in378 let next pc = 379 let _carry, res = half_add pc (vect_of_int 1 `Sixteen) in 380 res, WordMap.find pc pmem 381 in 382 let pc,instr = next pc in 383 let un, ln = from_byte instr in 384 let bits = (from_nibble un, from_nibble ln) in 383 385 match bits with 384 (a10,a9,a8,true),(false,false,false,true) >385 386 387  (false,false,true,false),(true,r1,r2,r3) >388 389  (false,false,true,false),(false,true,false,true) >390 let pc,b1 = next pc in 391 392  (false,false,true,false),(false,true,true,i1) >393 394  (false,false,true,false),(false,true,false,false) >395 let pc,b1 = next pc in 396 397  (false,false,true,true),(true,r1,r2,r3) >398 399  (false,false,true,true),(false,true,false,true) >400 let pc,b1 = next pc in 401 402  (false,false,true,true),(false,true,true,i1) >403 404  (false,false,true,true),(false,true,false,false) >405 let pc,b1 = next pc in 406 407  (a10,a9,a8,false),(false,false,false,true) >408 let pc,b1 = next pc in 409 410  (false,true,false,true),(true,r1,r2,r3) >411 412  (false,true,false,true),(false,true,false,true) >413 let pc,b1 = next pc in 414 415  (false,true,false,true),(false,true,true,i1) >416 417  (false,true,false,true),(false,true,false,false) >418 let pc,b1 = next pc in 419 420  (false,true,false,true),(false,false,true,false) >421 let pc,b1 = next pc in 422 423  (false,true,false,true),(false,false,true,true) >386 (a10,a9,a8,true),(false,false,false,true) > 387 let pc,b1 = next pc in 388 `ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2 389  (false,false,true,false),(true,r1,r2,r3) > 390 `ADD (`A,`REG (r1,r2,r3)), pc, 1 391  (false,false,true,false),(false,true,false,true) > 392 let pc,b1 = next pc in 393 `ADD (`A,`DIRECT b1), pc, 1 394  (false,false,true,false),(false,true,true,i1) > 395 `ADD (`A,`INDIRECT i1), pc, 1 396  (false,false,true,false),(false,true,false,false) > 397 let pc,b1 = next pc in 398 `ADD (`A,`DATA b1), pc, 1 399  (false,false,true,true),(true,r1,r2,r3) > 400 `ADDC (`A,`REG (r1,r2,r3)), pc, 1 401  (false,false,true,true),(false,true,false,true) > 402 let pc,b1 = next pc in 403 `ADDC (`A,`DIRECT b1), pc, 1 404  (false,false,true,true),(false,true,true,i1) > 405 `ADDC (`A,`INDIRECT i1), pc, 1 406  (false,false,true,true),(false,true,false,false) > 407 let pc,b1 = next pc in 408 `ADDC (`A,`DATA b1), pc, 1 409  (a10,a9,a8,false),(false,false,false,true) > 410 let pc,b1 = next pc in 411 `AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2 412  (false,true,false,true),(true,r1,r2,r3) > 413 `ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1 414  (false,true,false,true),(false,true,false,true) > 415 let pc,b1 = next pc in 416 `ANL (`U1 (`A, `DIRECT b1)), pc, 1 417  (false,true,false,true),(false,true,true,i1) > 418 `ANL (`U1 (`A, `INDIRECT i1)), pc, 1 419  (false,true,false,true),(false,true,false,false) > 420 let pc,b1 = next pc in 421 `ANL (`U1 (`A, `DATA b1)), pc, 1 422  (false,true,false,true),(false,false,true,false) > 423 let pc,b1 = next pc in 424 `ANL (`U2 (`DIRECT b1,`A)), pc, 1 425  (false,true,false,true),(false,false,true,true) > 424 426 let pc,b1 = next pc in 425 427 let pc,b2 = next pc in 426 427  (true,false,false,false),(false,false,true,false) >428 let pc,b1 = next pc in 429 430  (true,false,true,true),(false,false,false,false) >431 let pc,b1 = next pc in 432 433  (true,false,true,true),(false,true,false,true) >434 let 428 `ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2 429  (true,false,false,false),(false,false,true,false) > 430 let pc,b1 = next pc in 431 `ANL (`U3 (`C,`BIT b1)), pc, 2 432  (true,false,true,true),(false,false,false,false) > 433 let pc,b1 = next pc in 434 `ANL (`U3 (`C,`NBIT b1)), pc, 2 435  (true,false,true,true),(false,true,false,true) > 436 let pc,b1 = next pc in 435 437 let pc,b2 = next pc in 436 437  (true,false,true,true),(false,true,false,false) >438 439 440 441  (true,false,true,true),(true,r1,r2,r3) >442 443 444 445  (true,false,true,true),(false,true,true,i1) >446 447 448 449  (true,true,true,false),(false,true,false,false) >450 451  (true,true,false,false),(false,false,true,true) >452 453  (true,true,false,false),(false,false,true,false) >454 455 456  (true,true,true,true),(false,true,false,false) >457 458  (true,false,true,true),(false,false,true,true) >459 460  (true,false,true,true),(false,false,true,false) >461 462 463  (true,true,false,true),(false,true,false,false) >464 465  (false,false,false,true),(false,true,false,false) >466 467  (false,false,false,true),(true,r1,r2,r3) >468 469  (false,false,false,true),(false,true,false,true) >470 471 472  (false,false,false,true),(false,true,true,i1) >473 474  (true,false,false,false),(false,true,false,false) >475 476  (true,true,false,true),(true,r1,r2,r3) >477 478 479  (true,true,false,true),(false,true,false,true) >480 481 482 483  (false,false,false,false),(false,true,false,false) >484 485  (false,false,false,false),(true,r1,r2,r3) >486 487  (false,false,false,false),(false,true,false,true) >488 489 490  (false,false,false,false),(false,true,true,i1) >491 492  (true,false,true,false),(false,false,true,true) >493 494  (false,false,true,false),(false,false,false,false) >495 496 497 498  (false,false,false,true),(false,false,false,false) >499 500 501 502  (false,true,false,false),(false,false,false,false) >503 504 505  (false,true,true,true),(false,false,true,true) >506 507  (false,false,true,true),(false,false,false,false) >508 509 510 511  (false,true,false,true),(false,false,false,false) >512 513 514  (false,true,true,true),(false,false,false,false) >515 516 517  (false,true,true,false),(false,false,false,false) >518 519 520  (false,false,false,true),(false,false,true,false) >521 522 523 524  (false,false,false,false),(false,false,true,false) >525 526 527 438 `CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2 439  (true,false,true,true),(false,true,false,false) > 440 let pc,b1 = next pc in 441 let pc,b2 = next pc in 442 `CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2 443  (true,false,true,true),(true,r1,r2,r3) > 444 let pc,b1 = next pc in 445 let pc,b2 = next pc in 446 `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2 447  (true,false,true,true),(false,true,true,i1) > 448 let pc,b1 = next pc in 449 let pc,b2 = next pc in 450 `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2 451  (true,true,true,false),(false,true,false,false) > 452 `CLR `A, pc, 1 453  (true,true,false,false),(false,false,true,true) > 454 `CLR `C, pc, 1 455  (true,true,false,false),(false,false,true,false) > 456 let pc,b1 = next pc in 457 `CLR (`BIT b1), pc, 1 458  (true,true,true,true),(false,true,false,false) > 459 `CPL `A, pc, 1 460  (true,false,true,true),(false,false,true,true) > 461 `CPL `C, pc, 1 462  (true,false,true,true),(false,false,true,false) > 463 let pc,b1 = next pc in 464 `CPL (`BIT b1), pc, 1 465  (true,true,false,true),(false,true,false,false) > 466 `DA `A, pc, 1 467  (false,false,false,true),(false,true,false,false) > 468 `DEC `A, pc, 1 469  (false,false,false,true),(true,r1,r2,r3) > 470 `DEC (`REG(r1,r2,r3)), pc, 1 471  (false,false,false,true),(false,true,false,true) > 472 let pc,b1 = next pc in 473 `DEC (`DIRECT b1), pc, 1 474  (false,false,false,true),(false,true,true,i1) > 475 `DEC (`INDIRECT i1), pc, 1 476  (true,false,false,false),(false,true,false,false) > 477 `DIV (`A, `B), pc, 4 478  (true,true,false,true),(true,r1,r2,r3) > 479 let pc,b1 = next pc in 480 `DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2 481  (true,true,false,true),(false,true,false,true) > 482 let pc,b1 = next pc in 483 let pc,b2 = next pc in 484 `DJNZ (`DIRECT b1, `REL b2), pc, 2 485  (false,false,false,false),(false,true,false,false) > 486 `INC `A, pc, 1 487  (false,false,false,false),(true,r1,r2,r3) > 488 `INC (`REG(r1,r2,r3)), pc, 1 489  (false,false,false,false),(false,true,false,true) > 490 let pc,b1 = next pc in 491 `INC (`DIRECT b1), pc, 1 492  (false,false,false,false),(false,true,true,i1) > 493 `INC (`INDIRECT i1), pc, 1 494  (true,false,true,false),(false,false,true,true) > 495 `INC `DPTR, pc, 2 496  (false,false,true,false),(false,false,false,false) > 497 let pc,b1 = next pc in 498 let pc,b2 = next pc in 499 `JB (`BIT b1, `REL b2), pc, 2 500  (false,false,false,true),(false,false,false,false) > 501 let pc,b1 = next pc in 502 let pc,b2 = next pc in 503 `JBC (`BIT b1, `REL b2), pc, 2 504  (false,true,false,false),(false,false,false,false) > 505 let pc,b1 = next pc in 506 `JC (`REL b1), pc, 2 507  (false,true,true,true),(false,false,true,true) > 508 `JMP `IND_DPTR, pc, 2 509  (false,false,true,true),(false,false,false,false) > 510 let pc,b1 = next pc in 511 let pc,b2 = next pc in 512 `JNB (`BIT b1, `REL b2), pc, 2 513  (false,true,false,true),(false,false,false,false) > 514 let pc,b1 = next pc in 515 `JNC (`REL b1), pc, 2 516  (false,true,true,true),(false,false,false,false) > 517 let pc,b1 = next pc in 518 `JNZ (`REL b1), pc, 2 519  (false,true,true,false),(false,false,false,false) > 520 let pc,b1 = next pc in 521 `JZ (`REL b1), pc, 2 522  (false,false,false,true),(false,false,true,false) > 523 let pc,b1 = next pc in 524 let pc,b2 = next pc in 525 `LCALL (`ADDR16 (mk_word b1 b2)), pc, 2 526  (false,false,false,false),(false,false,true,false) > 527 let pc,b1 = next pc in 528 let pc,b2 = next pc in 529 `LJMP (`ADDR16 (mk_word b1 b2)), pc, 2 528 530  (true,true,true,false),(true,r1,r2,r3) > 529 531 `MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1 … … 1092 1094 1093 1095 let set_arg_8 status v = 1094 function1095 1096 1097 1098 1099 1096 function 1097 `DIRECT addr > 1098 let (b1, b2) = from_byte addr in 1099 (match from_nibble b1 with 1100 (false,r1,r2,r3) > 1101 { status with low_internal_ram = 1100 1102 Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram } 1101 1102  `INDIRECT b >1103 let (b1, b2) = from_byte (get_register status (false,false,b)) in1104 (match (from_nibble b1, b2) with1105 (false,r1,r2,r3),n1 >1106 { status with low_internal_ram =1107 1108 1109 1103  _ > set_sfr status addr v) 1104  `INDIRECT b > 1105 let (b1, b2) = from_byte (get_register status (false,false,b)) in 1106 (match (from_nibble b1, b2) with 1107 (false,r1,r2,r3),n1 > 1108 { status with low_internal_ram = 1109 Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram } 1110  (true,r1,r2,r3),n1 > 1111 { status with high_internal_ram = 1110 1112 Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram }) 1111  `REG (b1,b2,b3) >1113  `REG (b1,b2,b3) > 1112 1114 set_register status v (b1,b2,b3) 1113  `A > { status with acc = v }1114  `B > { status with b = v }1115  `EXT_IND_DPTR >1115  `A > { status with acc = v } 1116  `B > { status with b = v } 1117  `EXT_IND_DPTR > 1116 1118 let dpr = mk_word status.dph status.dpl in 1117 1119 { status with external_ram = 1118 1120 WordMap.add dpr v status.external_ram } 1119  `EXT_INDIRECT b >1120 let addr = get_register status (false,false,b) in1121 1122 1121  `EXT_INDIRECT b > 1122 let addr = get_register status (false,false,b) in 1123 { status with external_ram = 1124 WordMap.add (mk_word (zero `Eight) addr) v status.external_ram } 1123 1125 ;; 1124 1126 1125 1127 let set_arg_16 status wrd = 1126 1127 1128 1129 1130 1128 function 1129 `DPTR > 1130 let (dh, dl) = from_word wrd in 1131 { status with dph = dh; dpl = dl } 1132 1131 1133 let set_flags status c ac ov = 1132 { status with psw =1133 let bu,bl = from_byte status.psw in1134 let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in1135 let ac = match ac with None > oac  Some v > v in1134 { status with psw = 1135 let bu,bl = from_byte status.psw in 1136 let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in 1137 let ac = match ac with None > oac  Some v > v in 1136 1138 mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p) 1137 }1139 } 1138 1140 ;; 1139 1141 … … 1147 1149 1148 1150 let read_at_sp status = 1149 let n1,n2 = from_byte status.sp in1150 let m,r1,r2,r3 = from_nibble n1 in1151 let n1,n2 = from_byte status.sp in 1152 let m,r1,r2,r3 = from_nibble n1 in 1151 1153 Byte7Map.find (mk_byte7 r1 r2 r3 n2) 1152 (if m then status.low_internal_ram else status.high_internal_ram)1154 (if m then status.low_internal_ram else status.high_internal_ram) 1153 1155 ;; 1154 1156 1155 1157 let write_at_sp status v = 1156 let n1,n2 = from_byte status.sp in1157 match from_nibble n1 with1158 true,r1,r2,r3 >1159 1160 1161 1162 1163  false,r1,r2,r3 >1164 let memory =1165 1166 in1158 let n1,n2 = from_byte status.sp in 1159 match from_nibble n1 with 1160 true,r1,r2,r3 > 1161 let memory = 1162 Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram 1163 in 1164 { status with low_internal_ram = memory } 1165  false,r1,r2,r3 > 1166 let memory = 1167 Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram 1168 in 1167 1169 { status with high_internal_ram = memory } 1168 1170 ;; 1169 1171 1170 1172 let timer0 status b1 b2 ticks = 1171 1173 let b = get_bit status.tcon 4 in 1172 1174 (* Timer0 first *) 1173 1174 1175 (match b1,b2 with 1176 true,true > 1175 1177 (* Archaic 13 bit mode. *) 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1178 if b then 1179 let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in 1180 let res = int_of_vect res in 1181 if res > 31 then 1182 let res = res mod 32 in 1183 let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in 1184 if ov' then 1185 let b = set_bit status.tcon 7 true in 1186 { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight } 1187 else 1188 { status with th0 = res'; tl0 = vect_of_int res `Eight } 1189 else 1190 { status with tl0 = vect_of_int res `Eight } 1191 else 1192 status 1193  false,false > 1192 1194 (* 8 bit split timer mode. *) 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1195 let status = 1196 (if b then 1197 let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in 1198 if ov then 1199 let b = set_bit status.tcon 5 true in 1200 { status with tcon = b; tl0 = res } 1201 else 1202 { status with tl0 = res } 1203 else 1204 status) 1205 in 1206 if get_bit status.tcon 6 then 1207 let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in 1208 if ov then 1209 let b = set_bit status.tcon 7 true in 1210 { status with tcon = b; th0 = res } 1211 else 1212 { status with th0 = res } 1213 else 1214 status 1215  false,true > 1214 1216 (* 16 bit timer mode. *) 1215 1216 1217 if b then 1218 let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in 1217 1219 if ov then 1218 1220 let b = set_bit status.tcon 5 true in 1219 1221 let new_th0,new_tl0 = from_word res in 1220 1222 { status with tcon = b; th0 = new_th0; tl0 = new_tl0 } 1221 1223 else 1222 1224 let new_th0,new_tl0 = from_word res in 1223 1224 1225 1226 1225 { status with th0 = new_th0; tl0 = new_tl0 } 1226 else 1227 status 1228  true,false > 1227 1229 (* 8 bit single timer mode. *) 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1230 if b then 1231 let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in 1232 if ov then 1233 let b = set_bit status.tcon 5 true in 1234 { status with tcon = b; tl0 = status.th0; } 1235 else 1236 { status with tl0 = res } 1237 else 1238 status) 1239 1238 1240 let timer1 status b3 b4 ticks = 1239 1241 let b = get_bit status.tcon 4 in 1240 1242 (match b3,b4 with 1241 1243 true,true > 1242 1244 (* Archaic 13 bit mode. *) 1243 1245 if b then 1244 1246 let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in 1245 1247 let res = int_of_vect res in 1246 if res > 31 then 1247 let res = res mod 32 in 1248 let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in 1249 if ov' then 1250 let b = set_bit status.tcon 7 true in 1251 { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight } 1252 else 1253 { status with th1 = res'; tl0 = vect_of_int res `Eight } 1254 else 1255 { status with tl1 = vect_of_int res `Eight } 1248 if res > 31 then 1249 let res = res mod 32 in 1250 let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in 1251 if ov' then 1252 let b = set_bit status.tcon 7 true in 1253 { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight } 1256 1254 else 1257 status 1258  false,false > 1255 { status with th1 = res'; tl0 = vect_of_int res `Eight } 1256 else 1257 { status with tl1 = vect_of_int res `Eight } 1258 else 1259 status 1260  false,false > 1259 1261 (* 8 bit split timer mode. *) 1260 1261 1262 1263 1264 1262 let status = 1263 (if b then 1264 let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in 1265 if ov then 1266 let b = set_bit status.tcon 5 true in 1265 1267 { status with tcon = b; tl1 = res } 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1268 else 1269 { status with tl1 = res } 1270 else 1271 status) 1272 in 1273 if get_bit status.tcon 6 then 1274 let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in 1275 if ov then 1276 let b = set_bit status.tcon 7 true in 1277 { status with tcon = b; th1 = res } 1278 else 1279 { status with th1 = res } 1280 else 1281 status 1282  false,true > 1281 1283 (* 16 bit timer mode. *) 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1284 if b then 1285 let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in 1286 if ov then 1287 let b = set_bit status.tcon 5 true in 1288 let new_th1,new_tl1 = from_word res in 1289 { status with tcon = b; th1 = new_th1; tl1 = new_tl1 } 1290 else 1291 let new_th1,new_tl1 = from_word res in 1292 { status with th1 = new_th1; tl1 = new_tl1 } 1293 else 1294 status 1295  true,false > 1294 1296 (* 8 bit single timer mode. *) 1295 1296 1297 1298 1299 1300 1301 1302 1303 1297 if b then 1298 let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in 1299 if ov then 1300 let b = set_bit status.tcon 5 true in 1301 { status with tcon = b; tl1 = status.th1; } 1302 else 1303 { status with tl1 = res } 1304 else 1305 status) 1304 1306 ;; 1305 1307 … … 1310 1312 let status = 1311 1313 (if g0 then 1312 if get_bit status.p3 2 then 1313 if c0 then 1314 if status.previous_p1_val && not $ get_bit status.p3 4 then 1315 timer0 status b1 b2 ticks 1314 if get_bit status.p3 2 then 1315 if c0 then 1316 if status.previous_p1_val && not $ get_bit status.p3 4 then 1317 timer0 status b1 b2 ticks 1318 else 1319 status 1316 1320 else 1317 status1321 timer0 status b1 b2 ticks 1318 1322 else 1319 timer0 status b1 b2 ticks 1320 else 1321 status 1322 else 1323 timer0 status b1 b2 ticks) in 1323 status 1324 else 1325 timer0 status b1 b2 ticks) in 1324 1326 (* Timer 1 follows. *) 1325 1327 let status = 1326 1328 (if g1 then 1327 if get_bit status.p1 3 then1328 if c1 then1329 1330 timer1 status b3 b4 ticks1331 1332 status1333 else1334 1335 else1336 status1329 if get_bit status.p1 3 then 1330 if c1 then 1331 if status.previous_p3_val && not $ get_bit status.p3 5 then 1332 timer1 status b3 b4 ticks 1333 else 1334 status 1335 else 1336 timer1 status b3 b4 ticks 1337 else 1338 status 1337 1339 else 1338 1340 timer1 status b3 b4 ticks) in … … 1340 1342 let status = 1341 1343 (let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in 1342 (* Timer2 is enabled *)1343 1344 (* Timer2 is enabled *) 1345 if tr2 then 1344 1346 (* Counter/interval mode *) 1345 1346 1347 1348 1349 1350 1347 if ct2 && not cp2 then 1348 let word = mk_word status.th2 status.tl2 in 1349 let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in 1350 if ov then 1351 let new_th2 = status.rcap2h in 1352 let new_tl2 = status.rcap2l in 1351 1353 (* Overflow flag not set if either of the following flags are set *) 1352 1353 1354 1355 1356 1357 1358 1359 1360 1354 if not rclk && not tclk then 1355 let b = set_bit status.t2con 7 true in 1356 { status with t2con = b; 1357 th2 = new_th2; 1358 tl2 = new_tl2 } 1359 else 1360 { status with th2 = new_th2; 1361 tl2 = new_tl2 } 1362 else 1361 1363 (* Reload also signalled when a 10 transition is detected *) 1362 1364 if status.previous_p1_val && not $ get_bit status.p1 1 then 1363 1365 (* In which case signal reload by setting T2CON.6 *) 1364 1365 1366 1367 1368 1369 1370 1371 1372 (* Capture mode *)1373 1366 let b = set_bit status.t2con 6 true in 1367 { status with th2 = status.rcap2h; 1368 tl2 = status.rcap2l; 1369 t2con = b } 1370 else 1371 let new_th2, new_tl2 = from_word res in 1372 { status with th2 = new_th2; 1373 tl2 = new_tl2 } 1374 (* Capture mode *) 1375 else if cp2 && exen2 then 1374 1376 (* 10 transition detected *) 1375 1377 (* DPM: look at this: is the timer still running throughout? *) 1376 1377 1378 1379 1380 1381 1382 else1383 status) in status1384 1378 if status.previous_p1_val && not $ get_bit status.p1 1 then 1379 status (* Implement clock here *) 1380 else 1381 status (* Implement clock here *) 1382 else 1383 status 1384 else 1385 status) in status 1386 1385 1387 ;; 1386 1388 1387 1389 let serial_port_input status in_cont = 1388 (* Serial port input *)1389 1390 1391 1392 1393 `P1 b >1390 (* Serial port input *) 1391 match in_cont with 1392 Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 > 1393 (let status = 1394 (match line with 1395 `P1 b > 1394 1396 if status.clock >= time then 1395 1397 { status with p1 = b; p1_latch = b; } 1396 1398 else 1397 1399 status 1398  `P3 b >1399 1400 1401 1402 1403  `SerialBuff (`Eight b) >1404 1405 1406 1407 1400  `P3 b > 1401 if status.clock >= time then 1402 { status with p3 = b; p3_latch = b; } 1403 else 1404 status 1405  `SerialBuff (`Eight b) > 1406 let sm0 = get_bit status.scon 7 in 1407 let sm1 = get_bit status.scon 6 in 1408 (match (sm0, sm1) with 1409 (false, false) > 1408 1410 (* Mode 0: shift register. No delay. *) 1409 1410 1411 1412 1413 1414 1415 1411 if status.clock >= time then 1412 { status with scon = set_bit status.scon 0 true; 1413 io = cont; 1414 sbuf = b } 1415 else 1416 status 1417  (false, true) > 1416 1418 (* Mode 1: 8bit UART *) 1417 1419 (* Explanation: 8 bit asynchronous communication. There's a delay (epsilon) … … 1419 1421 an existing communication is occurring, we assert false (else clause of first 1420 1422 if). *) 1421 1422 1423 if status.serial_epsilon_in = None && status.serial_v_in = None then 1424 if status.clock >= time then 1423 1425 (* Waiting for nine bits, multiprocessor communication mode requires nine bits *) 1424 1425 1426 1427 1428 1429 1426 if get_bit status.scon 5 then 1427 assert false (* really: crash! *) 1428 else 1429 { status with serial_epsilon_in = Some (epsilon + time); 1430 serial_v_in = Some (`Eight b) } 1431 else 1430 1432 (* Warning about incomplete case analysis here, but safe as we've already tested for 1431 1433 None. *) 1432 let Some e = status.serial_epsilon_in in 1433 let Some v = status.serial_v_in in 1434 if status.clock >= e then 1435 match v with 1436 `Eight v' > 1437 { status with sbuf = v'; 1438 serial_v_in = None; 1439 serial_epsilon_in = None; 1440 scon = set_bit status.scon 0 true; 1441 io = cont } 1442  _ > assert false (* trying to read in 9 bits instead of 8 *) 1443 else 1444 status 1434 let Some e = status.serial_epsilon_in in 1435 let Some v = status.serial_v_in in 1436 if status.clock >= e then 1437 match v with 1438 `Eight v' > 1439 { status with sbuf = v'; 1440 serial_v_in = None; 1441 serial_epsilon_in = None; 1442 scon = set_bit status.scon 0 true; 1443 io = cont } 1444  _ > assert false (* trying to read in 9 bits instead of 8 *) 1445 1445 else 1446 assert false 1447  (true, false)  (true, true) > 1448 assert false (* only got eight bits on the line when in 9 bit mode *)) 1446 status 1447 else 1448 assert false 1449  (true, false)  (true, true) > 1450 assert false (* only got eight bits on the line when in 9 bit mode *)) 1449 1451  `SerialBuff (`Nine (b,b')) > 1450 1451 1452 1453 1454 1452 let sm0 = get_bit status.scon 7 in 1453 let sm1 = get_bit status.scon 6 in 1454 match(sm0, sm1) with 1455 (false, false)  (false, true) > assert false 1456  (true, false)  (true, true) > 1455 1457 (* Modes 2 and 3: 9bit UART *) 1456 1458 (* Explanation: 9 bit asynchronous communication. There's a delay (epsilon) … … 1458 1460 an existing communication is occurring, we assert false (else claus of first 1459 1461 if). *) 1460 1461 1462 if status.serial_epsilon_in = None && status.serial_v_in = None then 1463 if status.clock >= time then 1462 1464 (* waiting for nine bits, multiprocessor communication mode requires nine bits *) 1463 1464 1465 1466 1467 1468 1465 if get_bit status.scon 5 then 1466 assert false (* really: crash! *) 1467 else 1468 { status with serial_epsilon_in = Some (epsilon + time); 1469 serial_v_in = Some (`Nine (b, b')) } 1470 else 1469 1471 (* Warning about incomplete case analysis here, but safe as we've already tested for 1470 1472 None. *) 1471 let Some e = status.serial_epsilon_in in 1472 let Some v = status.serial_v_in in 1473 if status.clock >= e then 1474 match v with 1475 `Nine (v, v') > 1476 let scon' = set_bit status.scon 0 true in 1477 { status with sbuf = v'; 1478 serial_v_in = None; 1479 serial_epsilon_in = None; 1480 scon = set_bit scon' 2 b; 1481 io = cont } 1482  _ > assert false (* trying to read in 8 bits instead of 9 *) 1483 else 1484 status 1473 let Some e = status.serial_epsilon_in in 1474 let Some v = status.serial_v_in in 1475 if status.clock >= e then 1476 match v with 1477 `Nine (v, v') > 1478 let scon' = set_bit status.scon 0 true in 1479 { status with sbuf = v'; 1480 serial_v_in = None; 1481 serial_epsilon_in = None; 1482 scon = set_bit scon' 2 b; 1483 io = cont } 1484  _ > assert false (* trying to read in 8 bits instead of 9 *) 1485 1485 else 1486 assert false) 1487 in 1488 { status with io = cont }) 1489  _ > status 1486 status 1487 else 1488 assert false) 1489 in 1490 { status with io = cont }) 1491  _ > status 1490 1492 ;; 1491 1493 1492 1494 let serial_port_output status out_cont = 1493 1495 (* Serial port output *) 1494 1495 1496 1497 1498 Some s >1499 if status.clock >= s then1500 match status.serial_k_out with1501 None > assert false (* correct? *)1502  Some k' > { status with io = k';1503 1504 else1505 status1496 (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon); 1497 serial_v_out = Some (`Eight status.sbuf); 1498 serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in 1499 match status.serial_epsilon_out with 1500 Some s > 1501 if status.clock >= s then 1502 match status.serial_k_out with 1503 None > assert false (* correct? *) 1504  Some k' > { status with io = k'; 1505 scon = set_bit status.scon 1 true; } 1506 else 1507 status 1506 1508  _ > assert false) 1507 1509 ;; … … 1596 1598 let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in 1597 1599 (* DPM: are interrupts enabled? *) 1598 1599 1600 if ea then 1601 match (ps,pt1,px1,pt0,px0) with 1600 1602 _ > assert false 1601 1602 1603 else 1604 status 1603 1605 ;; 1604 1606 1605 1607 let execute1 status = 1606 let instr,pc,ticks = fetch status.code_memory status.pc in1607 let status = { status with clock = status.clock + ticks; pc = pc } in1608 let status =1609 (match instr with1610 1611 let v,c,ac,ov =1612 add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false1613 in1608 let instr,pc,ticks = fetch status.code_memory status.pc in 1609 let status = { status with clock = status.clock + ticks; pc = pc } in 1610 let status = 1611 (match instr with 1612 `ADD (`A,d1) > 1613 let v,c,ac,ov = 1614 add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false 1615 in 1614 1616 set_flags (set_arg_8 status v `A) c (Some ac) ov 1615  `ADDC (`A,d1) >1617  `ADDC (`A,d1) > 1616 1618 let v,c,ac,ov = 1617 1619 add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status) 1618 1620 in 1619 1620  `SUBB (`A,d1) >1621 set_flags (set_arg_8 status v `A) c (Some ac) ov 1622  `SUBB (`A,d1) > 1621 1623 let v,c,ac,ov = 1622 1624 subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status) 1623 1625 in 1624 1625  `INC `DPTR >1626 1627 1628 1629  `INC ((`A  `REG _  `DIRECT _  `INDIRECT _) as d) >1630 1631 1632 1633  `DEC d >1634 1635 1636 1637  `MUL (`A,`B) >1638 1639 1640 1641 1642 1643 1644 1626 set_flags (set_arg_8 status v `A) c (Some ac) ov 1627  `INC `DPTR > 1628 let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in 1629 let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in 1630 { status with dpl = low_order_byte; dph = high_order_byte } 1631  `INC ((`A  `REG _  `DIRECT _  `INDIRECT _) as d) > 1632 let b = get_arg_8 status true d in 1633 let cry, res = half_add b (vect_of_int 1 `Eight) in 1634 set_arg_8 status res d 1635  `DEC d > 1636 let b = get_arg_8 status true d in 1637 let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in 1638 set_arg_8 status res d 1639  `MUL (`A,`B) > 1640 let acc = int_of_vect status.acc in 1641 let b = int_of_vect status.b in 1642 let prod = acc * b in 1643 let ov = prod > 255 in 1644 let l = vect_of_int (prod mod 256) `Eight in 1645 let h = vect_of_int (prod / 256) `Eight in 1646 let status = { status with acc = l ; b = h } in 1645 1647 (* DPM: Carry flag is always cleared. *) 1646 1647  `DIV (`A,`B) >1648 1649 1650 1648 set_flags status false None ov 1649  `DIV (`A,`B) > 1650 let acc = int_of_vect status.acc in 1651 let b = int_of_vect status.b in 1652 if b = 0 then 1651 1653 (* CSC: ACC and B undefined! We leave them as they are. *) 1652 set_flags status false None true1653 1654 let q = vect_of_int (acc / b) `Eight in1655 let r = vect_of_int (acc mod b) `Eight in1656 let status = { status with acc = q ; b = r } in1654 set_flags status false None true 1655 else 1656 let q = vect_of_int (acc / b) `Eight in 1657 let r = vect_of_int (acc mod b) `Eight in 1658 let status = { status with acc = q ; b = r } in 1657 1659 set_flags status false None false 1658  `DA `A >1660  `DA `A > 1659 1661 let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in 1660 if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then 1661 let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in 1662 let acc_upper_nibble, acc_lower_nibble = from_byte acc in 1663 if int_of_vect acc_upper_nibble > 9 or cy = true then 1664 let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in 1665 let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in 1666 set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status) 1667 else 1668 status 1662 if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then 1663 let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in 1664 let acc_upper_nibble, acc_lower_nibble = from_byte acc in 1665 if int_of_vect acc_upper_nibble > 9 or cy = true then 1666 let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in 1667 let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in 1668 set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status) 1669 1669 else 1670 1670 status 1671  `ANL (`U1(`A, ag)) > 1671 else 1672 status 1673  `ANL (`U1(`A, ag)) > 1672 1674 let and_val = get_arg_8 status true `A & get_arg_8 status true ag in 1673 1674  `ANL (`U2((`DIRECT d), ag)) >1675 set_arg_8 status and_val `A 1676  `ANL (`U2((`DIRECT d), ag)) > 1675 1677 let and_val = get_arg_8 status true (`DIRECT d) & get_arg_8 status true ag in 1676 1677  `ANL (`U3 (`C, b)) >1678 set_arg_8 status and_val (`DIRECT d) 1679  `ANL (`U3 (`C, b)) > 1678 1680 let and_val = get_cy_flag status && get_arg_1 status true b in 1679 1680  `ORL (`U1(`A, ag)) >1681 set_flags status and_val None (get_ov_flag status) 1682  `ORL (`U1(`A, ag)) > 1681 1683 let or_val = get_arg_8 status true `A  get_arg_8 status true ag in 1682 1683  `ORL (`U2((`DIRECT d), ag)) >1684 set_arg_8 status or_val `A 1685  `ORL (`U2((`DIRECT d), ag)) > 1684 1686 let or_val = get_arg_8 status true (`DIRECT d)  get_arg_8 status true ag in 1685 1686  `ORL (`U3 (`C, b)) >1687 set_arg_8 status or_val (`DIRECT d) 1688  `ORL (`U3 (`C, b)) > 1687 1689 let or_val = get_cy_flag status  get_arg_1 status true b in 1688 1689  `XRL (`U1(`A, ag)) >1690 set_flags status or_val None (get_ov_flag status) 1691  `XRL (`U1(`A, ag)) > 1690 1692 let xor_val = get_arg_8 status true `A ^ get_arg_8 status true ag in 1691 1692  `XRL (`U2((`DIRECT d), ag)) >1693 set_arg_8 status xor_val `A 1694  `XRL (`U2((`DIRECT d), ag)) > 1693 1695 let xor_val = get_arg_8 status true (`DIRECT d) ^ get_arg_8 status true ag in 1694 1695  `CLR `A > set_arg_8 status (zero `Eight) `A1696  `CLR `C > set_arg_1 status false `C1697  `CLR ((`BIT _) as a) > set_arg_1 status false a1698  `CPL `A > { status with acc = complement status.acc }1699  `CPL `C > set_arg_1 status (not $ get_arg_1 status true `C) `C1700  `CPL ((`BIT _) as b) > set_arg_1 status (not $ get_arg_1 status true b) b1701  `RL `A > { status with acc = rotate_left status.acc }1702  `RLC `A >1696 set_arg_8 status xor_val (`DIRECT d) 1697  `CLR `A > set_arg_8 status (zero `Eight) `A 1698  `CLR `C > set_arg_1 status false `C 1699  `CLR ((`BIT _) as a) > set_arg_1 status false a 1700  `CPL `A > { status with acc = complement status.acc } 1701  `CPL `C > set_arg_1 status (not $ get_arg_1 status true `C) `C 1702  `CPL ((`BIT _) as b) > set_arg_1 status (not $ get_arg_1 status true b) b 1703  `RL `A > { status with acc = rotate_left status.acc } 1704  `RLC `A > 1703 1705 let old_cy = get_cy_flag status in 1704 1706 let n1, n2 = from_byte status.acc in 1705 1707 let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in 1706 1708 let status = set_arg_1 status b1 `C in 1707 1708  `RR `A > { status with acc = rotate_right status.acc }1709  `RRC `A >1709 { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) } 1710  `RR `A > { status with acc = rotate_right status.acc } 1711  `RRC `A > 1710 1712 let old_cy = get_cy_flag status in 1711 1713 let n1, n2 = from_byte status.acc in 1712 1714 let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in 1713 1715 let status = set_arg_1 status b8 `C in 1714 1715  `SWAP `A >1716 { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) } 1717  `SWAP `A > 1716 1718 let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in 1717 1718  `MOV(`U1(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b11719  `MOV(`U2(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b11720  `MOV(`U3(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b11721  `MOV(`U4(b1,b2)) > set_arg_16 status (get_arg_16 status b2) b11722  `MOV(`U5(b1,b2)) > set_arg_1 status (get_arg_1 status false b2) b11723  `MOV(`U6(b1,b2)) > set_arg_1 status (get_arg_1 status false b2) b11724  `MOVC (`A, `A_DPTR) >1725 1726 1727 1728 1729 1730  `MOVC (`A, `A_PC) >1731 1732 1733 1734 1735 1736 1737 1738 1739 (* data transfer *)1740 (* DPM: MOVX currently only implements the *copying* of data! *)1741  `MOVX (`U1 (a1, a2)) > set_arg_8 status (get_arg_8 status false a2) a11742  `MOVX (`U2 (a1, a2)) > set_arg_8 status (get_arg_8 status false a2) a11743  `SETB b > set_arg_1 status true b1744  `PUSH (`DIRECT b) >1719 { status with acc = mk_byte acc_nibble_lower acc_nibble_upper } 1720  `MOV(`U1(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b1 1721  `MOV(`U2(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b1 1722  `MOV(`U3(b1, b2)) > set_arg_8 status (get_arg_8 status false b2) b1 1723  `MOV(`U4(b1,b2)) > set_arg_16 status (get_arg_16 status b2) b1 1724  `MOV(`U5(b1,b2)) > set_arg_1 status (get_arg_1 status false b2) b1 1725  `MOV(`U6(b1,b2)) > set_arg_1 status (get_arg_1 status false b2) b1 1726  `MOVC (`A, `A_DPTR) > 1727 let big_acc = mk_word (zero `Eight) status.acc in 1728 let dptr = mk_word status.dph status.dpl in 1729 let cry, addr = half_add dptr big_acc in 1730 let lookup = WordMap.find addr status.code_memory in 1731 { status with acc = lookup } 1732  `MOVC (`A, `A_PC) > 1733 let big_acc = mk_word (zero `Eight) status.acc in 1734 (* DPM: Under specified: does the carry from PC incrementation affect the *) 1735 (* addition of the PC with the DPTR? At the moment, no. *) 1736 let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in 1737 let status = { status with pc = inc_pc } in 1738 let cry,addr = half_add inc_pc big_acc in 1739 let lookup = WordMap.find addr status.code_memory in 1740 { status with acc = lookup } 1741 (* data transfer *) 1742 (* DPM: MOVX currently only implements the *copying* of data! *) 1743  `MOVX (`U1 (a1, a2)) > set_arg_8 status (get_arg_8 status false a2) a1 1744  `MOVX (`U2 (a1, a2)) > set_arg_8 status (get_arg_8 status false a2) a1 1745  `SETB b > set_arg_1 status true b 1746  `PUSH (`DIRECT b) > 1745 1747 (* DPM: What happens if we overflow? *) 1746 1747 1748 let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in 1749 let status = { status with sp = new_sp } in 1748 1750 write_at_sp status b 1749  `POP (`DIRECT b) >1750 1751 1752 1753 1754 1755  `XCH(`A, arg) >1756 1757 1758 1759 1760  `XCHD(`A, i) >1761 1762 1763 1764 1765 1766 1767 (* program branching *)1768  `JC (`REL rel) >1769 1770 let cry, new_pc = half_add status.pc (sign_extension rel) in1771 1772 1773 status1774  `JNC (`REL rel) >1775 1776 let cry, new_pc = half_add status.pc (sign_extension rel) in1777 1778 1779 status1780  `JB (b, (`REL rel)) >1781 1782 let cry, new_pc = half_add status.pc (sign_extension rel) in1783 1784 1785 status1786  `JNB (b, (`REL rel)) >1787 1788 let cry, new_pc = half_add status.pc (sign_extension rel) in1789 1790 1791 status1792  `JBC (b, (`REL rel)) >1793 1794 1795 1796 1797 1798 1799  `RET >1800 1801 1802 1803 1804 1805 1806 1807 1808  `RETI >1809 1810 1811 1812 1813 1814 1815 1816  `ACALL (`ADDR11 a) >1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829  `LCALL (`ADDR16 addr) >1830 1831 1832 1833 1834 1835 1836 1837 1838  `AJMP (`ADDR11 a) >1839 1840 1841 1842 1843 1844 1845 1846  `LJMP (`ADDR16 a) >1847 1848  `SJMP (`REL rel) >1849 1850 1851  `JMP `IND_DPTR >1852 1853 1854 1855 1856 1857  `JZ (`REL rel) >1858 1859 let cry, new_pc = half_add status.pc (sign_extension rel) in1860 1861 1862 status1863  `JNZ (`REL rel) >1864 1865 let cry, new_pc = half_add status.pc (sign_extension rel) in1866 1867 1868 status1869  `CJNE ((`U1 (`A, ag)), `REL rel) >1870 1871 1872 1873 1874 1875 1876 1877  `CJNE ((`U2 (ag, `DATA d)), `REL rel) >1878 1879 1880 let cry, new_pc = half_add status.pc (sign_extension rel) in1881 let status = { status with pc = new_pc } in1882 1883 1884 set_flags status new_carry None (get_ov_flag status)1885  `DJNZ (ag, (`REL rel)) >1886 1887 1888 1889 1890 1891 1892 1893  `NOP > status) in1751  `POP (`DIRECT b) > 1752 let contents = read_at_sp status in 1753 let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in 1754 let status = { status with sp = new_sp } in 1755 let status = set_arg_8 status contents (`DIRECT b) in 1756 status 1757  `XCH(`A, arg) > 1758 let old_arg = get_arg_8 status false arg in 1759 let old_acc = status.acc in 1760 let status = set_arg_8 status old_acc arg in 1761 { status with acc = old_arg } 1762  `XCHD(`A, i) > 1763 let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in 1764 let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in 1765 let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in 1766 let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in 1767 let status = { status with acc = new_acc } in 1768 set_arg_8 status new_reg i 1769 (* program branching *) 1770  `JC (`REL rel) > 1771 if get_cy_flag status then 1772 let cry, new_pc = half_add status.pc (sign_extension rel) in 1773 { status with pc = new_pc } 1774 else 1775 status 1776  `JNC (`REL rel) > 1777 if not $ get_cy_flag status then 1778 let cry, new_pc = half_add status.pc (sign_extension rel) in 1779 { status with pc = new_pc } 1780 else 1781 status 1782  `JB (b, (`REL rel)) > 1783 if get_arg_1 status false b then 1784 let cry, new_pc = half_add status.pc (sign_extension rel) in 1785 { status with pc = new_pc } 1786 else 1787 status 1788  `JNB (b, (`REL rel)) > 1789 if not $ get_arg_1 status false b then 1790 let cry, new_pc = half_add status.pc (sign_extension rel) in 1791 { status with pc = new_pc } 1792 else 1793 status 1794  `JBC (b, (`REL rel)) > 1795 let status = set_arg_1 status false b in 1796 if get_arg_1 status false b then 1797 let cry, new_pc = half_add status.pc (sign_extension rel) in 1798 { status with pc = new_pc } 1799 else 1800 status 1801  `RET > 1802 (* DPM: What happens when we underflow? *) 1803 let high_bits = read_at_sp status in 1804 let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in 1805 let status = { status with sp = new_sp } in 1806 let low_bits = read_at_sp status in 1807 let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in 1808 let status = { status with sp = new_sp } in 1809 { status with pc = mk_word high_bits low_bits } 1810  `RETI > 1811 let high_bits = read_at_sp status in 1812 let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in 1813 let status = { status with sp = new_sp } in 1814 let low_bits = read_at_sp status in 1815 let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in 1816 let status = { status with sp = new_sp } in 1817 { status with pc = mk_word high_bits low_bits } 1818  `ACALL (`ADDR11 a) > 1819 let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in 1820 let status = { status with sp = new_sp } in 1821 let pc_upper_byte, pc_lower_byte = from_word status.pc in 1822 let status = write_at_sp status pc_lower_byte in 1823 let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in 1824 let status = { status with sp = new_sp } in 1825 let status = write_at_sp status pc_upper_byte in 1826 let n1, n2 = from_byte pc_upper_byte in 1827 let (b1,b2,b3,_) = from_word11 a in 1828 let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in 1829 let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) pc_lower_byte in 1830 { status with pc = addr } 1831  `LCALL (`ADDR16 addr) > 1832 let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in 1833 let status = { status with sp = new_sp } in 1834 let pc_upper_byte, pc_lower_byte = from_word status.pc in 1835 let status = write_at_sp status pc_lower_byte in 1836 let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in 1837 let status = { status with sp = new_sp } in 1838 let status = write_at_sp status pc_upper_byte in 1839 { status with pc = addr } 1840  `AJMP (`ADDR11 a) > 1841 let pc_upper_byte, pc_lower_byte = from_word status.pc in 1842 let n1, n2 = from_byte pc_upper_byte in 1843 let (p1,p2,p3,p4),(p5,_,_,_) = from_nibble n1, from_nibble n2 in 1844 let (b1,b2,b3,b) = from_word11 a in 1845 let addr = mk_word (mk_byte (mk_nibble p1 p2 p3 p4) (mk_nibble p5 b1 b2 b3)) b in 1846 let cry, new_pc = half_add status.pc addr in 1847 { status with pc = new_pc } 1848  `LJMP (`ADDR16 a) > 1849 { status with pc = a } 1850  `SJMP (`REL rel) > 1851 let cry, new_pc = half_add status.pc (sign_extension rel) in 1852 { status with pc = new_pc } 1853  `JMP `IND_DPTR > 1854 let dptr = mk_word status.dph status.dpl in 1855 let big_acc = mk_word (zero `Eight) status.acc in 1856 let cry, jmp_addr = half_add big_acc dptr in 1857 let cry, new_pc = half_add status.pc jmp_addr in 1858 { status with pc = new_pc } 1859  `JZ (`REL rel) > 1860 if status.acc = zero `Eight then 1861 let cry, new_pc = half_add status.pc (sign_extension rel) in 1862 { status with pc = new_pc } 1863 else 1864 status 1865  `JNZ (`REL rel) > 1866 if status.acc <> zero `Eight then 1867 let cry, new_pc = half_add status.pc (sign_extension rel) in 1868 { status with pc = new_pc } 1869 else 1870 status 1871  `CJNE ((`U1 (`A, ag)), `REL rel) > 1872 let new_carry = status.acc < get_arg_8 status false ag in 1873 if get_arg_8 status false ag <> status.acc then 1874 let cry, new_pc = half_add status.pc (sign_extension rel) in 1875 let status = set_flags status new_carry None (get_ov_flag status) in 1876 { status with pc = new_pc; } 1877 else 1878 set_flags status new_carry None (get_ov_flag status) 1879  `CJNE ((`U2 (ag, `DATA d)), `REL rel) > 1880 let new_carry = get_arg_8 status false ag < d in 1881 if get_arg_8 status false ag <> d then 1882 let cry, new_pc = half_add status.pc (sign_extension rel) in 1883 let status = { status with pc = new_pc } in 1884 set_flags status new_carry None (get_ov_flag status) 1885 else 1886 set_flags status new_carry None (get_ov_flag status) 1887  `DJNZ (ag, (`REL rel)) > 1888 let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in 1889 let status = set_arg_8 status new_ag ag in 1890 if new_ag <> zero `Eight then 1891 let cry, new_pc = half_add status.pc (sign_extension rel) in 1892 { status with pc = new_pc } 1893 else 1894 status 1895  `NOP > status) in 1894 1896 let status = timers status ticks in 1895 1897 let in_cont, `Out out_cont = status.io in … … 1897 1899 let status = serial_port_output status out_cont in 1898 1900 let status = interrupts status in 1899 1900 1901 { status with previous_p1_val = get_bit status.p3 4; 1902 previous_p3_val = get_bit status.p3 5 } 1901 1903 ;; 1902 1904 … … 1922 1924 1923 1925 let rec execute f s = 1924 let cont =1925 try f s; true1926 with Halt > false1927 in1926 let cont = 1927 try f s; true 1928 with Halt > false 1929 in 1928 1930 if cont then execute f (execute1 s) 1929 1931 else s
Note: See TracChangeset
for help on using the changeset viewer.