contrib/space-invaders/cpu-8080.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 !
   3 ! Redistribution and use in source and binary forms, with or without
   4 ! modification, are permitted provided that the following conditions are met:
   5 !
   6 ! 1. Redistributions of source code must retain the above copyright notice,
   7 !    this list of conditions and the following disclaimer.
   8 !
   9 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  10 !    this list of conditions and the following disclaimer in the documentation
  11 !    and/or other materials provided with the distribution.
  12 !
  13 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  14 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  15 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  16 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  17 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  18 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  19 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  20 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  21 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  22 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23 USING: kernel math sequences errors vectors prettyprint io
  24 namespaces arrays words parser hashtables lazy-lists
  25 kernel-internals parser-combinators strings ;
  26 IN: cpu-8080
  27
  28 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
  29
  30 GENERIC: reset        ( cpu            -- )
  31 GENERIC: update-video ( value addr cpu -- )
  32 GENERIC: read-port    ( port cpu       -- byte )
  33 GENERIC: write-port   ( value port cpu -- )
  34
  35 M: cpu update-video ( value addr cpu -- )
  36   3drop ;
  37
  38 M: cpu read-port ( port cpu -- byte )
  39   #! Read a byte from the hardware port. 'port' should
  40   #! be an 8-bit value.
  41   2drop 0 ;
  42
  43 M: cpu write-port ( value port cpu -- )
  44   #! Write a byte to the hardware port, where 'port' is
  45   #! an 8-bit value.
  46   3drop ;
  47
  48 : carry-flag        HEX: 01 ; inline
  49 : parity-flag       HEX: 04 ; inline
  50 : half-carry-flag   HEX: 10 ; inline
  51 : interrupt-flag    HEX: 20 ; inline
  52 : zero-flag         HEX: 40 ; inline
  53 : sign-flag         HEX: 80 ; inline
  54
  55 : >word< ( word -- byte byte )
  56   #! Explode a word into its two 8 bit values.
  57   dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
  58
  59 : cpu-af ( cpu -- word )
  60   #! Return the 16-bit pseudo register AF.
  61   [ cpu-a 8 shift ] keep cpu-f bitor ;
  62
  63 : set-cpu-af ( value cpu -- )
  64   #! Set the value of the 16-bit pseudo register AF
  65   >r >word< r> tuck set-cpu-f set-cpu-a ;
  66
  67 : cpu-bc ( cpu -- word )
  68   #! Return the 16-bit pseudo register BC.
  69   [ cpu-b 8 shift ] keep cpu-c bitor ;
  70
  71 : set-cpu-bc ( value cpu -- )
  72   #! Set the value of the 16-bit pseudo register BC
  73   >r >word< r> tuck set-cpu-c set-cpu-b ;
  74
  75 : cpu-de ( cpu -- word )
  76   #! Return the 16-bit pseudo register DE.
  77   [ cpu-d 8 shift ] keep cpu-e bitor ;
  78
  79 : set-cpu-de ( value cpu -- )
  80   #! Set the value of the 16-bit pseudo register DE
  81   >r >word< r> tuck set-cpu-e set-cpu-d ;
  82
  83 : cpu-hl ( cpu -- word )
  84   #! Return the 16-bit pseudo register HL.
  85   [ cpu-h 8 shift ] keep cpu-l bitor ;
  86
  87 : set-cpu-hl ( value cpu -- )
  88   #! Set the value of the 16-bit pseudo register HL
  89   >r >word< r> tuck set-cpu-l set-cpu-h ;
  90
  91 : flag-set? ( flag cpu -- bool )
  92   cpu-f bitand 0 = not ;
  93
  94 : flag-clear? ( flag cpu -- bool )
  95   cpu-f bitand 0 = ;
  96
  97 : flag-nz? ( cpu -- bool )
  98   #! Test flag status
  99   cpu-f zero-flag bitand 0 = ;
 100
 101 : flag-z? ( cpu -- bool )
 102   #! Test flag status
 103   cpu-f zero-flag bitand 0 = not ;
 104
 105 : flag-nc? ( cpu -- bool )
 106   #! Test flag status
 107   cpu-f carry-flag bitand 0 = ;
 108
 109 : flag-c? ( cpu -- bool )
 110   #! Test flag status
 111   cpu-f carry-flag bitand 0 = not ;
 112
 113 : flag-po? ( cpu -- bool )
 114   #! Test flag status
 115   cpu-f parity-flag bitand 0 =  ;
 116
 117 : flag-pe? ( cpu -- bool )
 118   #! Test flag status
 119   cpu-f parity-flag bitand 0 = not ;
 120
 121 : flag-p? ( cpu -- bool )
 122   #! Test flag status
 123   cpu-f sign-flag bitand 0 = ;
 124
 125 : flag-m? ( cpu -- bool )
 126   #! Test flag status
 127   cpu-f sign-flag bitand 0 = not ;
 128
 129 : read-byte ( addr cpu -- byte )
 130   #! Read one byte from memory at the specified address.
 131   #! The address is 16-bit, but if a value greater than
 132   #! 0xFFFF is provided then return a default value.
 133   over HEX: FFFF <= [
 134     cpu-ram nth
 135   ] [
 136     2drop HEX: FF
 137   ] if ;
 138
 139 : read-word ( addr cpu -- word )
 140   #! Read a 16-bit word from memory at the specified address.
 141   #! The address is 16-bit, but if a value greater than
 142   #! 0xFFFF is provided then return a default value.
 143   [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
 144
 145 : next-byte ( cpu -- byte )
 146   #! Return the value of the byte at PC, and increment PC.
 147   [ cpu-pc ] keep
 148   [ read-byte ] keep
 149   [ cpu-pc 1 + ] keep
 150   set-cpu-pc ;
 151
 152 : next-word ( cpu -- word )
 153   #! Return the value of the word at PC, and increment PC.
 154   [ cpu-pc ] keep
 155   [ read-word ] keep
 156   [ cpu-pc 2 + ] keep
 157   set-cpu-pc ;
 158
 159
 160 : write-byte ( value addr cpu -- )
 161   #! Write a byte to the specified memory address.
 162   over dup HEX: 2000 < swap HEX: FFFF > or [
 163     3drop
 164   ] [
 165     3dup cpu-ram set-nth
 166     update-video
 167   ] if ;
 168
 169
 170 : write-word ( value addr cpu -- )
 171   #! Write a 16-bit word to the specified memory address.
 172   >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
 173
 174 : cpu-a-bitand ( quot cpu -- )
 175   #! A &= quot call
 176   [ cpu-a swap call bitand ] keep set-cpu-a ; inline
 177
 178 : cpu-a-bitor ( quot cpu -- )
 179   #! A |= quot call
 180   [ cpu-a swap call bitor ] keep set-cpu-a ; inline
 181
 182 : cpu-a-bitxor ( quot cpu -- )
 183   #! A ^= quot call
 184   [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
 185
 186 : cpu-a-bitxor= ( value cpu -- )
 187   #! cpu-a ^= value
 188   [ cpu-a bitxor ] keep set-cpu-a ;
 189
 190 : cpu-f-bitand ( quot cpu -- )
 191   #! F &= quot call
 192   [ cpu-f swap call bitand ] keep set-cpu-f ; inline
 193
 194 : cpu-f-bitor ( quot cpu -- )
 195   #! F |= quot call
 196   [ cpu-f swap call bitor ] keep set-cpu-f ; inline
 197
 198 : cpu-f-bitxor ( quot cpu -- )
 199   #! F |= quot call
 200   [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
 201
 202 : cpu-f-bitor= ( value cpu -- )
 203   #! cpu-f |= value
 204   [ cpu-f bitor ] keep set-cpu-f ;
 205
 206 : cpu-f-bitand= ( value cpu -- )
 207   #! cpu-f &= value
 208   [ cpu-f bitand ] keep set-cpu-f ;
 209
 210 : cpu-f-bitxor= ( value cpu -- )
 211   #! cpu-f ^= value
 212   [ cpu-f bitxor ] keep set-cpu-f ;
 213
 214 : set-flag ( cpu flag -- )
 215   swap cpu-f-bitor= ;
 216
 217 : clear-flag ( cpu flag -- )
 218    bitnot HEX: FF bitand swap cpu-f-bitand= ;
 219
 220 : update-zero-flag ( result cpu -- )
 221   #! If the result of an instruction has the value 0, this
 222   #! flag is set, otherwise it is reset.
 223   swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
 224
 225 : update-sign-flag ( result cpu -- )
 226   #! If the most significant bit of the result
 227   #! has the value 1 then the flag is set, otherwise
 228   #! it is reset.
 229   swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
 230
 231 : update-parity-flag ( result cpu -- )
 232   #! If the modulo 2 sum of the bits of the result
 233   #! is 0, (ie. if the result has even parity) this flag
 234   #! is set, otherwise it is reset.
 235   swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
 236
 237 : update-carry-flag ( result cpu -- )
 238   #! If the instruction resulted in a carry (from addition)
 239   #! or a borrow (from subtraction or a comparison) out of the
 240   #! higher order bit, this flag is set, otherwise it is reset.
 241   swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
 242
 243 : update-half-carry-flag ( original change-by result cpu -- )
 244   #! If the instruction caused a carry out of bit 3 and into bit 4 of the
 245   #! resulting value, the half carry flag is set, otherwise it is reset.
 246   #! The 'original' is the original value of the register being changed.
 247   #! 'change-by' is the amount it is being added or decremented by.
 248   #! 'result' is the result of that change.
 249   >r bitxor bitxor HEX: 10 bitand 0 = not r>
 250   swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
 251
 252 : update-flags ( result cpu -- )
 253   2dup update-carry-flag
 254   2dup update-parity-flag
 255   2dup update-sign-flag
 256   update-zero-flag ;
 257
 258 : update-flags-no-carry ( result cpu -- )
 259   2dup update-parity-flag
 260   2dup update-sign-flag
 261   update-zero-flag ;
 262
 263 : add-byte ( lhs rhs cpu -- result )
 264   #! Add rhs to lhs
 265   >r 2dup + r> ! lhs rhs result cpu
 266   [ update-flags ] 2keep
 267   [ update-half-carry-flag ] 2keep
 268   drop HEX: FF bitand ;
 269
 270 : add-carry ( change-by result cpu -- change-by result )
 271   #! Add the effect of the carry flag to the result
 272   flag-c? [ 1 + >r 1 + r> ] when ;
 273
 274 : add-byte-with-carry ( lhs rhs cpu -- result )
 275   #! Add rhs to lhs plus carry.
 276   >r 2dup + r> ! lhs rhs result cpu
 277   [ add-carry ] keep
 278   [ update-flags ] 2keep
 279   [ update-half-carry-flag ] 2keep
 280   drop HEX: FF bitand ;
 281
 282 : sub-carry ( change-by result cpu -- change-by result )
 283   #! Subtract the effect of the carry flag from the result
 284   flag-c? [ 1 - >r 1 - r>  ] when ;
 285
 286 : sub-byte ( lhs rhs cpu -- result )
 287   #! Subtract rhs from lhs
 288   >r 2dup - r>
 289   [ update-flags ] 2keep
 290   [ update-half-carry-flag ] 2keep
 291   drop HEX: FF bitand ;
 292
 293 : sub-byte-with-carry ( lhs rhs cpu -- result )
 294   #! Subtract rhs from lhs and take carry into account
 295   >r 2dup - r>
 296   [ sub-carry ] keep
 297   [ update-flags ] 2keep
 298   [ update-half-carry-flag ] 2keep
 299   drop HEX: FF bitand ;
 300
 301 : inc-byte ( byte cpu -- result )
 302   #! Increment byte by one. Note that carry flag is not affected
 303   #! by this operation.
 304   >r 1 2dup + r> ! lhs rhs result cpu
 305   [ update-flags-no-carry ] 2keep
 306   [ update-half-carry-flag ] 2keep
 307   drop HEX: FF bitand ;
 308
 309 : dec-byte ( byte cpu -- result )
 310   #! Decrement byte by one. Note that carry flag is not affected
 311   #! by this operation.
 312   >r 1 2dup - r> ! lhs rhs result cpu
 313   [ update-flags-no-carry ] 2keep
 314   [ update-half-carry-flag ] 2keep
 315   drop HEX: FF bitand ;
 316
 317 : inc-word ( w cpu -- w )
 318   #! Increment word by one. Note that no flags are modified.
 319   drop 1 + HEX: FFFF bitand ;
 320
 321 : dec-word ( w cpu -- w )
 322   #! Decrement word by one. Note that no flags are modified.
 323   drop 1 - HEX: FFFF bitand ;
 324
 325 : add-word ( lhs rhs cpu -- result )
 326   #! Add rhs to lhs. Note that only the carry flag is modified
 327   #! and only if there is a carry out of the double precision add.
 328   >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
 329
 330 : bit3or ( lhs rhs -- 0|1 )
 331   #! bitor bit 3 of the two numbers on the stack
 332   BIN: 00001000 bitand -3 shift >r
 333   BIN: 00001000 bitand -3 shift r>
 334   bitor ;
 335
 336 : and-byte ( lhs rhs cpu -- result )
 337   #! Logically and rhs to lhs. The carry flag is cleared and
 338   #! the half carry is set to the ORing of bits 3 of the operands.
 339   [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
 340   >r bitand r> [ update-flags ] 2keep
 341   [ carry-flag clear-flag ] keep
 342   rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
 343   HEX: FF bitand ;
 344
 345 : xor-byte ( lhs rhs cpu -- result )
 346   #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
 347   >r bitxor r> [ update-flags ] 2keep
 348   [ half-carry-flag carry-flag bitor clear-flag ] keep
 349   drop HEX: FF bitand ;
 350
 351 : or-byte ( lhs rhs cpu -- result )
 352   #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
 353   >r bitor r> [ update-flags ] 2keep
 354   [ half-carry-flag carry-flag bitor clear-flag ] keep
 355   drop HEX: FF bitand ;
 356
 357 : flags ( seq -- seq )
 358   [ 0 [ execute bitor ] reduce ] map ;
 359
 360 : decrement-sp ( n cpu -- )
 361   #! Decrement the stackpointer by n.
 362   [ cpu-sp ] keep
 363   >r swap - r> set-cpu-sp ;
 364
 365 : save-pc ( cpu -- )
 366   #! Save the value of the PC on the stack.
 367   [ cpu-pc ] keep ! pc cpu
 368   [ cpu-sp ] keep ! pc sp cpu
 369   write-word ;
 370
 371 : push-pc ( cpu -- )
 372   #! Push the value of the PC on the stack.
 373   2 over decrement-sp
 374   save-pc ;
 375
 376 : pop-pc ( cpu -- pc )
 377   #! Pop the value of the PC off the stack.
 378   [ cpu-sp ] keep
 379   [ read-word ] keep
 380   -2 swap decrement-sp ;
 381
 382 : push-sp ( value cpu -- )
 383   [ 2 swap decrement-sp ] keep
 384   [ cpu-sp ] keep
 385   write-word ;
 386
 387 : pop-sp ( cpu -- value )
 388   [ cpu-sp ] keep
 389   [ read-word ] keep
 390   -2 swap decrement-sp ;
 391
 392 : call-sub ( addr cpu -- )
 393   #! Call the address as a subroutine.
 394   dup push-pc
 395   >r HEX: FFFF bitand r> set-cpu-pc ;
 396
 397 : ret-from-sub ( cpu -- )
 398   [ pop-pc ] keep set-cpu-pc ;
 399
 400 : interrupt ( number cpu -- )
 401   #! Perform a hardware interrupt
 402 !  "***Interrupt: " write over 16 >base print
 403   dup cpu-f interrupt-flag bitand 0 = not [
 404     dup push-pc
 405     set-cpu-pc
 406   ] [
 407     2drop
 408   ] if ;
 409
 410 : inc-cycles ( n cpu -- )
 411   #! Increment the number of cpu cycles
 412   [ cpu-cycles + ] keep set-cpu-cycles ;
 413
 414 : instruction-cycles ( -- vector )
 415   #! Return a 256 element vector containing the cycles for
 416   #! each opcode in the 8080 instruction set.
 417   {
 418     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 419     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 420     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 421     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 422     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 423     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 424     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 425     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
 426
 427 : instructions ( -- vector )
 428   #! Return a 256 element vector containing the emulation words for
 429   #! each opcode in the 8080 instruction set.
 430   {
 431     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 432     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 433     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 434     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 435     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 436     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 437     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
 438     f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; inline
 439
 440 : not-implemented ( <cpu> -- )
 441   drop ;
 442
 443 instructions length [
 444   dup instructions nth [
 445     drop
 446   ] [
 447     [ not-implemented ] swap instructions set-nth
 448   ] if
 449 ] each
 450
 451 M: cpu reset ( cpu -- )
 452   #! Reset the CPU to its poweron state
 453   [ 0 swap set-cpu-b  ] keep
 454   [ 0 swap set-cpu-c  ] keep
 455   [ 0 swap set-cpu-d  ] keep
 456   [ 0 swap set-cpu-e  ] keep
 457   [ 0 swap set-cpu-h  ] keep
 458   [ 0 swap set-cpu-l  ] keep
 459   [ 0 swap set-cpu-a  ] keep
 460   [ 0 swap set-cpu-f  ] keep
 461   [ 0 swap set-cpu-pc  ] keep
 462   [ HEX: F000 swap set-cpu-sp  ] keep
 463   [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
 464   [ f swap set-cpu-halted? ] keep
 465   [ HEX: 10 swap set-cpu-last-interrupt ] keep
 466   0 swap set-cpu-cycles ;
 467
 468 C: cpu ( cpu -- cpu )
 469   [ reset ] keep ;
 470
 471 : (load-rom) ( n ram -- )
 472   read1 [ ! n ram ch
 473     -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
 474   ] [
 475     2drop
 476   ] if* ;
 477
 478   #! Reads the ROM from stdin and stores it in ROM from
 479   #! offset n.
 480 : load-rom ( filename <cpu> -- )
 481   #! Load the contents of the file into ROM.
 482   #! (address 0x0000-0x1FFF).
 483   cpu-ram swap <file-reader> [
 484     0 swap (load-rom)
 485   ] with-stream ;
 486
 487 : load-rom* ( addr filename <cpu> -- )
 488   #! Load the contents of the file into ROM, starting at
 489   #! the specified address.
 490   cpu-ram swap <file-reader> [
 491     (load-rom)
 492   ] with-stream ;
 493
 494 : read-instruction ( cpu -- word )
 495   #! Read the next instruction from the cpu's program
 496   #! counter, and increment the program counter.
 497   [ cpu-pc ] keep ! pc cpu
 498   [ over 1 + swap set-cpu-pc ] keep
 499   read-byte ;
 500
 501 : get-cycles ( n -- opcode )
 502   #! Returns the cycles for the given instruction value.
 503   #! If the opcode is not defined throw an error.
 504   dup instruction-cycles nth [
 505     nip
 506   ] [
 507     [ "Undefined 8080 opcode: " % number>string % ] "" make throw
 508   ] if* ;
 509
 510 : process-interrupts ( cpu -- )
 511   #! Process any hardware interrupts
 512   [ cpu-cycles ] keep
 513   over 16667 < [
 514     2drop
 515   ] [
 516     [ >r 16667 - r> set-cpu-cycles ] keep
 517     dup cpu-last-interrupt HEX: 10 = [
 518       HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
 519     ] [
 520       HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
 521     ] if
 522   ] if ;
 523
 524 : step ( cpu -- )
 525   #! Run a single 8080 instruction
 526   [ read-instruction ] keep ! n cpu
 527   over get-cycles over inc-cycles
 528   [ swap instructions dispatch ] keep
 529   [ cpu-pc HEX: FFFF bitand ] keep
 530   [ set-cpu-pc ] keep
 531   process-interrupts ;
 532
 533 : peek-instruction ( cpu -- word )
 534   #! Return the next instruction from the cpu's program
 535   #! counter, but don't increment the counter.
 536   [ cpu-pc ] keep read-byte instructions nth first ;
 537
 538 : cpu. ( cpu -- )
 539   [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
 540   [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
 541   [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
 542   [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
 543   [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
 544   [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
 545   [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
 546   [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
 547   [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
 548   [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
 549   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
 550   [ " " write peek-instruction word-name write " " write ] keep
 551   terpri drop ;
 552
 553 : cpu*. ( cpu -- )
 554   [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
 555   [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
 556   [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
 557   [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
 558   [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
 559   [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
 560   [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
 561   [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
 562   [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
 563   [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
 564   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
 565   terpri drop ;
 566
 567 : test-step ( cpu -- cpu )
 568   [ step ] keep dup cpu. ;
 569
 570 : test-cpu ( -- cpu )
 571   <cpu> "invaders.rom" over load-rom dup cpu. ;
 572
 573 : test-n ( n -- )
 574   test-cpu swap [ test-step ] times ;
 575
 576 : run-n ( cpu n -- )
 577   [ dup step ] times ;
 578
 579 : register-lookup ( string -- vector )
 580   #! Given a string containing a register name, return a vector
 581   #! where the 1st item is the getter and the 2nd is the setter
 582   #! for that register.
 583   H{
 584     { "A"  { cpu-a  set-cpu-a  } }
 585     { "B"  { cpu-b  set-cpu-b  } }
 586     { "C"  { cpu-c  set-cpu-c  } }
 587     { "D"  { cpu-d  set-cpu-d  } }
 588     { "E"  { cpu-e  set-cpu-e  } }
 589     { "H"  { cpu-h  set-cpu-h  } }
 590     { "L"  { cpu-l  set-cpu-l  } }
 591     { "AF" { cpu-af set-cpu-af } }
 592     { "BC" { cpu-bc set-cpu-bc } }
 593     { "DE" { cpu-de set-cpu-de } }
 594     { "HL" { cpu-hl set-cpu-hl } }
 595     { "SP" { cpu-sp set-cpu-sp } }
 596   } hash ;
 597
 598
 599 : flag-lookup ( string -- vector )
 600   #! Given a string containing a flag name, return a vector
 601   #! where the 1st item is a word that tests that flag.
 602   H{
 603     { "NZ"  { flag-nz?  } }
 604     { "NC"  { flag-nc?  } }
 605     { "PO"  { flag-po?  } }
 606     { "PE"  { flag-pe?  } }
 607     { "Z"  { flag-z?  } }
 608     { "C"  { flag-c? } }
 609     { "P"  { flag-p?  } }
 610     { "M" { flag-m?  } }
 611   } hash ;
 612
 613 SYMBOL: $1
 614 SYMBOL: $2
 615 SYMBOL: $3
 616 SYMBOL: $4
 617
 618 : replace-patterns ( vector tree -- tree )
 619   #! Copy the tree, replacing each occurence of
 620   #! $1, $2, etc with the relevant item from the
 621   #! given index.
 622   dup quotation? over [ ] = not and [ ! vector tree
 623     dup first swap 1 tail ! vector car cdr
 624     >r dupd replace-patterns ! vector v R: cdr
 625     swap r> replace-patterns >r unit r> append
 626   ] [ ! vector value
 627     dup $1 = [ drop 0 over nth  ] when
 628     dup $2 = [ drop 1 over nth  ] when
 629     dup $3 = [ drop 2 over nth  ] when
 630     dup $4 = [ drop 3 over nth  ] when
 631     nip
 632   ] if ;
 633
 634 : test-rp
 635   { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
 636
 637 : (emulate-RST) ( n cpu -- )
 638   #! RST nn
 639   [ cpu-sp 2 - dup ] keep ! sp sp cpu
 640   [ set-cpu-sp ] keep ! sp cpu
 641   [ cpu-pc ] keep ! sp pc cpu
 642   swapd [ write-word ] keep ! cpu
 643   >r 8 * r> set-cpu-pc ;
 644
 645 : (emulate-CALL) ( cpu -- )
 646   #! 205 - CALL nn
 647   [ next-word HEX: FFFF bitand ] keep ! addr cpu
 648   [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
 649   [ set-cpu-sp ] keep ! addr sp cpu
 650   [ cpu-pc ] keep ! addr sp pc cpu
 651   swapd [ write-word ] keep ! addr cpu
 652   set-cpu-pc ;
 653
 654 : (emulate-RLCA) ( cpu -- )
 655   #! The content of the accumulator is rotated left
 656   #! one position. The low order bit and the carry flag
 657   #! are both set to the value shifd out of the high
 658   #! order bit position. Only the carry flag is affected.
 659   [ cpu-a -7 shift ] keep
 660   over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 661   [ cpu-a 1 shift HEX: FF bitand ] keep
 662   >r bitor r> set-cpu-a ;
 663
 664 : (emulate-RRCA) ( cpu -- )
 665   #! The content of the accumulator is rotated right
 666   #! one position. The high order bit and the carry flag
 667   #! are both set to the value shifd out of the low
 668   #! order bit position. Only the carry flag is affected.
 669   [ cpu-a 1 bitand 7 shift ] keep
 670   over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 671   [ cpu-a 254 bitand -1 shift ] keep
 672   >r bitor r> set-cpu-a ;
 673
 674 : (emulate-RLA) ( cpu -- )
 675   #! The content of the accumulator is rotated left
 676   #! one position through the carry flag. The low
 677   #! order bit is set equal to the carry flag and
 678   #! the carry flag is set to the value shifd out
 679   #! of the high order bit. Only the carry flag is
 680   #! affected.
 681   [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
 682   [ cpu-a 127 bitand 7 shift ] keep
 683   dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 684   >r bitor r> set-cpu-a ;
 685
 686 : (emulate-RRA) ( cpu -- )
 687   #! The content of the accumulator is rotated right
 688   #! one position through the carry flag. The high order
 689   #! bit is set to the carry flag and the carry flag is
 690   #! set to the value shifd out of the low order bit.
 691   #! Only the carry flag is affected.
 692   [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
 693   [ cpu-a 254 bitand -1 shift ] keep
 694   dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 695   >r bitor r> set-cpu-a ;
 696
 697 : (emulate-CPL) ( cpu -- )
 698   #! The contents of the accumulator are complemented
 699   #! (zero bits become one, one bits becomes zero).
 700   #! No flags are affected.
 701   HEX: FF swap cpu-a-bitxor= ;
 702
 703 : (emulate-DAA) ( cpu -- )
 704   #! The eight bit number in the accumulator is
 705   #! adjusted to form two four-bit binary-coded-decimal
 706   #! digits.
 707   [
 708     dup half-carry-flag swap flag-set? swap
 709     cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
 710   ] keep
 711   [ cpu-a + ] keep
 712   [ update-flags ] 2keep
 713   [ swap HEX: FF bitand swap set-cpu-a ] keep
 714   [
 715     dup carry-flag swap flag-set? swap
 716     cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
 717   ] keep
 718   [ cpu-a + ] keep
 719   [ update-flags ] 2keep
 720   swap HEX: FF bitand swap set-cpu-a ;
 721
 722 : patterns ( -- hashtable )
 723   #! table of code quotation patterns for each type of instruction.
 724   H{
 725     { "NOP"          [ drop ]               }
 726     { "RET-NN"          [ ret-from-sub  ]               }
 727     { "RST-0"      [ 0 swap (emulate-RST) ] }
 728     { "RST-8"      [ 8 swap (emulate-RST) ] }
 729     { "RST-10H"      [ HEX: 10 swap (emulate-RST) ] }
 730     { "RST-18H"      [ HEX: 18 swap (emulate-RST) ] }
 731     { "RST-20H"      [ HEX: 20 swap (emulate-RST) ] }
 732     { "RST-28H"      [ HEX: 28 swap (emulate-RST) ] }
 733     { "RST-30H"      [ HEX: 30 swap (emulate-RST) ] }
 734     { "RST-38H"      [ HEX: 38 swap (emulate-RST) ] }
 735     { "RET-F|FF"      [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
 736     { "CP-N"      [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
 737     { "CP-R"      [ [ cpu-a ] keep [ $1 ] keep sub-byte drop  ] }
 738     { "CP-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
 739     { "OR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
 740     { "OR-R"      [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
 741     { "OR-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a  ] }
 742     { "XOR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
 743     { "XOR-R"      [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
 744     { "XOR-(RR)"   [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a  ] }
 745     { "AND-N"      [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a  ] }
 746     { "AND-R"      [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
 747     { "AND-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a  ] }
 748     { "ADC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
 749     { "ADC-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
 750     { "ADC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
 751     { "ADD-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
 752     { "ADD-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
 753     { "ADD-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
 754     { "ADD-R,(RR)"    [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2   ]  }
 755     { "SBC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
 756     { "SBC-R,R"      [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
 757     { "SBC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
 758     { "SUB-R"      [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
 759     { "SUB-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
 760     { "SUB-N"      [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
 761     { "CPL"          [ (emulate-CPL) ]               }
 762     { "DAA"          [ (emulate-DAA) ]               }
 763     { "RLA"          [ (emulate-RLA) ]               }
 764     { "RRA"          [ (emulate-RRA) ]               }
 765     { "CCF"          [ carry-flag swap cpu-f-bitxor= ]               }
 766     { "SCF"          [ carry-flag swap cpu-f-bitor= ]               }
 767     { "RLCA"          [ (emulate-RLCA) ]               }
 768     { "RRCA"          [ (emulate-RRCA) ]               }
 769     { "HALT"          [ drop  ]               }
 770     { "DI"          [ [ 255 interrupt-flag - ] swap cpu-f-bitand  ]               }
 771     { "EI"          [ [ interrupt-flag ] swap cpu-f-bitor  ]  }
 772     { "POP-RR"     [ [ pop-sp ] keep $2 ] }
 773     { "PUSH-RR"     [ [ $1 ] keep push-sp ] }
 774     { "INC-R"     [ [ $1 ] keep [ inc-byte ] keep $2 ] }
 775     { "DEC-R"     [ [ $1 ] keep [ dec-byte ] keep $2 ] }
 776     { "INC-RR"     [ [ $1 ] keep [ inc-word ] keep $2 ] }
 777     { "DEC-RR"     [ [ $1 ] keep [ dec-word ] keep $2 ] }
 778     { "DEC-(RR)"     [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
 779     { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep  [ $1 ] keep write-byte ] }
 780     { "JP-NN"           [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ]               }
 781     { "JP-F|FF,NN"      [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
 782     { "JP-(RR)"      [ [ $1 ] keep set-cpu-pc ] }
 783     { "CALL-NN"         [ (emulate-CALL) ] }
 784     { "CALL-F|FF,NN"    [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ]   }
 785     { "LD-RR,NN"     [ [ next-word ] keep $2 ] }
 786     { "LD-RR,RR"     [ [ $3 ] keep $2 ] }
 787     { "LD-R,N"     [ [ next-byte ] keep $2 ] }
 788     { "LD-(RR),N"    [ [ next-byte ] keep [ $1 ] keep write-byte ] }
 789     { "LD-(RR),R"    [ [ $3 ] keep [ $1 ] keep write-byte ] }
 790     { "LD-R,R"    [ [ $3 ] keep $2 ] }
 791     { "LD-R,(RR)"    [ [ $3 ] keep [ read-byte ] keep $2  ] }
 792     { "LD-(NN),RR"    [ [ $1 ] keep [ next-word ] keep write-word ] }
 793     { "LD-(NN),R"    [  [ $1 ] keep [ next-word ] keep write-byte ] }
 794     { "LD-RR,(NN)"    [ [ next-word ] keep [ read-word ] keep $2 ]  }
 795     { "LD-R,(NN)"    [ [ next-word ] keep [ read-byte ] keep $2 ] }
 796     { "OUT-(N),R"    [ [ $1 ] keep [ next-byte ] keep write-port ] }
 797     { "IN-R,(N)"    [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
 798     { "EX-(RR),RR"  [  [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
 799     { "EX-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
 800   } ;
 801
 802 : 8-bit-registers ( -- parser )
 803   #! A parser for 8-bit registers. On a successfull parse the
 804   #! parse tree contains a vector. The first item in the vector
 805   #! is the getter word for that register with stack effect
 806   #! ( cpu -- value ). The second item is the setter word with
 807   #! stack effect ( value cpu -- ).
 808   "A" token
 809   "B" token  <|>
 810   "C" token  <|>
 811   "D" token  <|>
 812   "E" token  <|>
 813   "H" token  <|>
 814   "L" token  <|> [ register-lookup ] <@ ;
 815
 816 : all-flags
 817   #! A parser for 16-bit flags.
 818   "NZ" token
 819   "NC" token <|>
 820   "PO" token <|>
 821   "PE" token <|>
 822   "Z" token <|>
 823   "C" token <|>
 824   "P" token <|>
 825   "M" token <|> [ flag-lookup ] <@ ;
 826
 827 : 16-bit-registers
 828   #! A parser for 16-bit registers. On a successfull parse the
 829   #! parse tree contains a vector. The first item in the vector
 830   #! is the getter word for that register with stack effect
 831   #! ( cpu -- value ). The second item is the setter word with
 832   #! stack effect ( value cpu -- ).
 833   "AF" token
 834   "BC" token <|>
 835   "DE" token <|>
 836   "HL" token <|>
 837   "SP" token <|> [ register-lookup ] <@ ;
 838
 839 : all-registers ( -- parser )
 840   #! Return a parser that can parse the format
 841   #! for 8 bit or 16 bit registers.
 842   8-bit-registers 16-bit-registers <|> ;
 843
 844 : indirect ( parser -- parser )
 845   #! Given a parser, return a parser which parses the original
 846   #! wrapped in brackets, representing an indirect reference.
 847   #! eg. BC -> (BC). The value of the original parser is left in
 848   #! the parse tree.
 849   "(" token swap &> ")" token <& ;
 850
 851 : generate-instruction ( vector string -- quot )
 852   #! Generate the quotation for an instruction, given the instruction in
 853   #! the 'string' and a vector containing the arguments for that instruction.
 854   patterns hash replace-patterns ;
 855
 856 : simple-instruction ( token -- parser )
 857   #! Return a parser for then instruction identified by the token.
 858   #! The parser return parses the token only and expects no additional
 859   #! arguments to the instruction.
 860   token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
 861
 862 : complex-instruction ( type token -- parser )
 863   #! Return a parser for an instruction identified by the token.
 864   #! The instruction is expected to take additional arguments by
 865   #! being combined with other parsers. Then 'type' is used for a lookup
 866   #! in a pattern hashtable to return the instruction quotation pattern.
 867   token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
 868
 869 : NOP-instruction ( -- parser )
 870   "NOP" simple-instruction ;
 871
 872 : RET-NN-instruction ( -- parser )
 873   "RET-NN" "RET" complex-instruction
 874   "nn" token sp <&
 875   just [ { } clone swap curry  ] <@ ;
 876
 877 : RST-0-instruction ( -- parser )
 878   "RST-0" "RST" complex-instruction
 879   "0" token sp <&
 880   just [ { } clone swap curry  ] <@ ;
 881
 882 : RST-8-instruction ( -- parser )
 883   "RST-8" "RST" complex-instruction
 884   "8" token sp <&
 885   just [ { } clone swap curry  ] <@ ;
 886
 887 : RST-10H-instruction ( -- parser )
 888   "RST-10H" "RST" complex-instruction
 889   "10H" token sp <&
 890   just [ { } clone swap curry  ] <@ ;
 891
 892 : RST-18H-instruction ( -- parser )
 893   "RST-18H" "RST" complex-instruction
 894   "18H" token sp <&
 895   just [ { } clone swap curry  ] <@ ;
 896
 897 : RST-20H-instruction ( -- parser )
 898   "RST-20H" "RST" complex-instruction
 899   "20H" token sp <&
 900   just [ { } clone swap curry  ] <@ ;
 901
 902 : RST-28H-instruction ( -- parser )
 903   "RST-28H" "RST" complex-instruction
 904   "28H" token sp <&
 905   just [ { } clone swap curry  ] <@ ;
 906
 907 : RST-30H-instruction ( -- parser )
 908   "RST-30H" "RST" complex-instruction
 909   "30H" token sp <&
 910   just [ { } clone swap curry  ] <@ ;
 911
 912 : RST-38H-instruction ( -- parser )
 913   "RST-38H" "RST" complex-instruction
 914   "38H" token sp <&
 915   just [ { } clone swap curry  ] <@ ;
 916
 917 : JP-NN-instruction ( -- parser )
 918   "JP-NN" "JP" complex-instruction
 919   "nn" token sp <&
 920   just [ { } clone swap curry  ] <@ ;
 921
 922 : JP-F|FF,NN-instruction ( -- parser )
 923   "JP-F|FF,NN" "JP" complex-instruction
 924   all-flags sp <&>
 925   ",nn" token <&
 926   just [ first2 swap curry ] <@ ;
 927
 928 : JP-(RR)-instruction ( -- parser )
 929   "JP-(RR)" "JP" complex-instruction
 930   16-bit-registers indirect sp <&>
 931   just [ first2 swap curry ] <@ ;
 932
 933 : CALL-NN-instruction ( -- parser )
 934   "CALL-NN" "CALL" complex-instruction
 935   "nn" token sp <&
 936   just [ { } clone swap curry  ] <@ ;
 937
 938 : CALL-F|FF,NN-instruction ( -- parser )
 939   "CALL-F|FF,NN" "CALL" complex-instruction
 940   all-flags sp <&>
 941   ",nn" token <&
 942   just [ first2 swap curry ] <@ ;
 943
 944 : RLCA-instruction ( -- parser )
 945   "RLCA" simple-instruction ;
 946
 947 : RRCA-instruction ( -- parser )
 948   "RRCA" simple-instruction ;
 949
 950 : HALT-instruction ( -- parser )
 951   "HALT" simple-instruction ;
 952
 953 : DI-instruction ( -- parser )
 954   "DI" simple-instruction ;
 955
 956 : EI-instruction ( -- parser )
 957   "EI" simple-instruction ;
 958
 959 : CPL-instruction ( -- parser )
 960   "CPL" simple-instruction ;
 961
 962 : CCF-instruction ( -- parser )
 963   "CCF" simple-instruction ;
 964
 965 : SCF-instruction ( -- parser )
 966   "SCF" simple-instruction ;
 967
 968 : DAA-instruction ( -- parser )
 969   "DAA" simple-instruction ;
 970
 971 : RLA-instruction ( -- parser )
 972   "RLA" simple-instruction ;
 973
 974 : RRA-instruction ( -- parser )
 975   "RRA" simple-instruction ;
 976
 977 : DEC-R-instruction ( -- parser )
 978   "DEC-R" "DEC" complex-instruction  8-bit-registers sp <&>
 979   just [ first2 swap curry ] <@ ;
 980
 981 : DEC-RR-instruction ( -- parser )
 982   "DEC-RR" "DEC" complex-instruction  16-bit-registers sp <&>
 983   just [ first2 swap curry ] <@ ;
 984
 985 : DEC-(RR)-instruction ( -- parser )
 986   "DEC-(RR)" "DEC" complex-instruction
 987   16-bit-registers indirect sp <&>
 988   just [ first2 swap curry ] <@ ;
 989
 990 : POP-RR-instruction ( -- parser )
 991   "POP-RR" "POP" complex-instruction  all-registers sp <&>
 992   just [ first2 swap curry ] <@ ;
 993
 994 : PUSH-RR-instruction ( -- parser )
 995   "PUSH-RR" "PUSH" complex-instruction  all-registers sp <&>
 996   just [ first2 swap curry ] <@ ;
 997
 998 : INC-R-instruction ( -- parser )
 999   "INC-R" "INC" complex-instruction  8-bit-registers sp <&>
1000   just [ first2 swap curry ] <@ ;
1001
1002 : INC-RR-instruction ( -- parser )
1003   "INC-RR" "INC" complex-instruction  16-bit-registers sp <&>
1004   just [ first2 swap curry ] <@ ;
1005
1006 : INC-(RR)-instruction  ( -- parser )
1007   "INC-(RR)" "INC" complex-instruction
1008   all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1009
1010 : RET-F|FF-instruction ( -- parser )
1011   "RET-F|FF" "RET" complex-instruction  all-flags sp <&>
1012   just [ first2 swap curry ] <@ ;
1013
1014 : AND-N-instruction ( -- parser )
1015   "AND-N" "AND" complex-instruction
1016   "n" token sp <&
1017   just [ { } clone swap curry  ] <@ ;
1018
1019 : AND-R-instruction  ( -- parser )
1020   "AND-R" "AND" complex-instruction
1021   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1022
1023 : AND-(RR)-instruction  ( -- parser )
1024   "AND-(RR)" "AND" complex-instruction
1025   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1026
1027 : XOR-N-instruction ( -- parser )
1028   "XOR-N" "XOR" complex-instruction
1029   "n" token sp <&
1030   just [ { } clone swap curry  ] <@ ;
1031
1032 : XOR-R-instruction  ( -- parser )
1033   "XOR-R" "XOR" complex-instruction
1034   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1035
1036 : XOR-(RR)-instruction  ( -- parser )
1037   "XOR-(RR)" "XOR" complex-instruction
1038   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1039
1040 : OR-N-instruction ( -- parser )
1041   "OR-N" "OR" complex-instruction
1042   "n" token sp <&
1043   just [ { } clone swap curry  ] <@ ;
1044
1045 : OR-R-instruction  ( -- parser )
1046   "OR-R" "OR" complex-instruction
1047   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1048
1049 : OR-(RR)-instruction  ( -- parser )
1050   "OR-(RR)" "OR" complex-instruction
1051   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1052
1053 : CP-N-instruction ( -- parser )
1054   "CP-N" "CP" complex-instruction
1055   "n" token sp <&
1056   just [ { } clone swap curry  ] <@ ;
1057
1058 : CP-R-instruction  ( -- parser )
1059   "CP-R" "CP" complex-instruction
1060   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1061
1062 : CP-(RR)-instruction  ( -- parser )
1063   "CP-(RR)" "CP" complex-instruction
1064   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1065
1066 : ADC-R,N-instruction ( -- parser )
1067   "ADC-R,N" "ADC" complex-instruction
1068   8-bit-registers sp <&>
1069   ",n" token <&
1070   just [ first2 swap curry ] <@ ;
1071
1072 : ADC-R,R-instruction ( -- parser )
1073   "ADC-R,R" "ADC" complex-instruction
1074   8-bit-registers sp <&>
1075   "," token <&
1076   8-bit-registers <&>
1077   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1078
1079 : ADC-R,(RR)-instruction ( -- parser )
1080   "ADC-R,(RR)" "ADC" complex-instruction
1081   8-bit-registers sp <&>
1082   "," token <&
1083   16-bit-registers indirect <&>
1084   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1085
1086 : SBC-R,N-instruction ( -- parser )
1087   "SBC-R,N" "SBC" complex-instruction
1088   8-bit-registers sp <&>
1089   ",n" token <&
1090   just [ first2 swap curry ] <@ ;
1091
1092 : SBC-R,R-instruction ( -- parser )
1093   "SBC-R,R" "SBC" complex-instruction
1094   8-bit-registers sp <&>
1095   "," token <&
1096   8-bit-registers <&>
1097   just [ first2 swap first2 swap >r swap append r> curry  ] <@ ;
1098
1099 : SBC-R,(RR)-instruction ( -- parser )
1100   "SBC-R,(RR)" "SBC" complex-instruction
1101   8-bit-registers sp <&>
1102   "," token <&
1103   16-bit-registers indirect  <&>
1104   just [ first2 swap first2 swap >r swap append r> curry  ] <@ ;
1105
1106 : SUB-R-instruction ( -- parser )
1107   "SUB-R" "SUB" complex-instruction
1108   8-bit-registers sp <&>
1109   just [ first2 swap curry ] <@ ;
1110
1111 : SUB-(RR)-instruction ( -- parser )
1112   "SUB-(RR)" "SUB" complex-instruction
1113   16-bit-registers indirect sp <&>
1114   just [ first2 swap curry ] <@ ;
1115
1116 : SUB-N-instruction ( -- parser )
1117   "SUB-N" "SUB" complex-instruction
1118   "n" token sp <&
1119   just [ { } clone swap curry  ] <@ ;
1120
1121 : ADD-R,N-instruction ( -- parser )
1122   "ADD-R,N" "ADD" complex-instruction
1123   8-bit-registers sp <&>
1124   ",n" token <&
1125   just [ first2 swap curry ] <@ ;
1126
1127 : ADD-R,R-instruction ( -- parser )
1128   "ADD-R,R" "ADD" complex-instruction
1129   8-bit-registers sp <&>
1130   "," token <&
1131   8-bit-registers <&>
1132   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1133
1134 : ADD-RR,RR-instruction ( -- parser )
1135   "ADD-RR,RR" "ADD" complex-instruction
1136   16-bit-registers sp <&>
1137   "," token <&
1138   16-bit-registers <&>
1139   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1140
1141 : ADD-R,(RR)-instruction ( -- parser )
1142   "ADD-R,(RR)" "ADD" complex-instruction
1143   8-bit-registers sp <&>
1144   "," token <&
1145   16-bit-registers indirect <&>
1146   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1147
1148 : LD-RR,NN-instruction
1149   #! LD BC,nn
1150   "LD-RR,NN" "LD" complex-instruction
1151   16-bit-registers sp <&>
1152   ",nn" token <&
1153   just [ first2 swap curry ] <@ ;
1154
1155 : LD-R,N-instruction
1156   #! LD B,n
1157   "LD-R,N" "LD" complex-instruction
1158   8-bit-registers sp <&>
1159   ",n" token <&
1160   just [ first2 swap curry ] <@ ;
1161
1162 : LD-(RR),N-instruction
1163   "LD-(RR),N" "LD" complex-instruction
1164   16-bit-registers indirect sp <&>
1165   ",n" token <&
1166   just [ first2 swap curry ] <@ ;
1167
1168 : LD-(RR),R-instruction
1169   #! LD (BC),A
1170   "LD-(RR),R" "LD" complex-instruction
1171   16-bit-registers indirect sp <&>
1172   "," token <&
1173   8-bit-registers <&>
1174   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1175
1176 : LD-R,R-instruction
1177   "LD-R,R" "LD" complex-instruction
1178   8-bit-registers sp <&>
1179   "," token <&
1180   8-bit-registers <&>
1181   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1182
1183 : LD-RR,RR-instruction
1184   "LD-RR,RR" "LD" complex-instruction
1185   16-bit-registers sp <&>
1186   "," token <&
1187   16-bit-registers <&>
1188   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1189
1190 : LD-R,(RR)-instruction
1191   "LD-R,(RR)" "LD" complex-instruction
1192   8-bit-registers sp <&>
1193   "," token <&
1194   16-bit-registers indirect <&>
1195   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1196
1197 : LD-(NN),RR-instruction
1198   "LD-(NN),RR" "LD" complex-instruction
1199   "nn" token indirect sp <&
1200   "," token <&
1201   16-bit-registers <&>
1202   just [ first2 swap curry ] <@ ;
1203
1204 : LD-(NN),R-instruction
1205   "LD-(NN),R" "LD" complex-instruction
1206   "nn" token indirect sp <&
1207   "," token <&
1208   8-bit-registers <&>
1209   just [ first2 swap curry ] <@ ;
1210
1211 : LD-RR,(NN)-instruction
1212   "LD-RR,(NN)" "LD" complex-instruction
1213   16-bit-registers sp <&>
1214   "," token <&
1215   "nn" token indirect <&
1216   just [ first2 swap curry ] <@ ;
1217
1218 : LD-R,(NN)-instruction
1219   "LD-R,(NN)" "LD" complex-instruction
1220   8-bit-registers sp <&>
1221   "," token <&
1222   "nn" token indirect <&
1223   just [ first2 swap curry ] <@ ;
1224
1225 : OUT-(N),R-instruction
1226   "OUT-(N),R" "OUT" complex-instruction
1227   "n" token indirect sp <&
1228   "," token <&
1229   8-bit-registers <&>
1230   just [ first2 swap curry ] <@ ;
1231
1232 : IN-R,(N)-instruction
1233   "IN-R,(N)" "IN" complex-instruction
1234   8-bit-registers sp <&>
1235   "," token <&
1236   "n" token indirect <&
1237   just [ first2 swap curry ] <@ ;
1238
1239 : EX-(RR),RR-instruction
1240   "EX-(RR),RR" "EX" complex-instruction
1241   16-bit-registers indirect sp <&>
1242   "," token <&
1243   16-bit-registers <&>
1244   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1245
1246 : EX-RR,RR-instruction
1247   "EX-RR,RR" "EX" complex-instruction
1248   16-bit-registers sp <&>
1249   "," token <&
1250   16-bit-registers <&>
1251   just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1252
1253 : 8080-generator-parser
1254   NOP-instruction
1255   RST-0-instruction <|>
1256   RST-8-instruction <|>
1257   RST-10H-instruction <|>
1258   RST-18H-instruction <|>
1259   RST-20H-instruction <|>
1260   RST-28H-instruction <|>
1261   RST-30H-instruction <|>
1262   RST-38H-instruction <|>
1263   JP-F|FF,NN-instruction <|>
1264   JP-NN-instruction <|>
1265   JP-(RR)-instruction <|>
1266   CALL-F|FF,NN-instruction <|>
1267   CALL-NN-instruction <|>
1268   CPL-instruction <|>
1269   CCF-instruction <|>
1270   SCF-instruction <|>
1271   DAA-instruction <|>
1272   RLA-instruction <|>
1273   RRA-instruction <|>
1274   RLCA-instruction <|>
1275   RRCA-instruction <|>
1276   HALT-instruction <|>
1277   DI-instruction <|>
1278   EI-instruction <|>
1279   AND-N-instruction <|>
1280   AND-R-instruction <|>
1281   AND-(RR)-instruction <|>
1282   XOR-N-instruction <|>
1283   XOR-R-instruction <|>
1284   XOR-(RR)-instruction <|>
1285   OR-N-instruction <|>
1286   OR-R-instruction <|>
1287   OR-(RR)-instruction <|>
1288   CP-N-instruction <|>
1289   CP-R-instruction <|>
1290   CP-(RR)-instruction <|>
1291   DEC-RR-instruction <|>
1292   DEC-R-instruction <|>
1293   DEC-(RR)-instruction <|>
1294   POP-RR-instruction <|>
1295   PUSH-RR-instruction <|>
1296   INC-RR-instruction <|>
1297   INC-R-instruction <|>
1298   INC-(RR)-instruction <|>
1299   LD-RR,NN-instruction <|>
1300   LD-R,N-instruction <|>
1301   LD-R,R-instruction <|>
1302   LD-RR,RR-instruction <|>
1303   LD-(RR),N-instruction <|>
1304   LD-(RR),R-instruction <|>
1305   LD-R,(RR)-instruction <|>
1306   LD-(NN),RR-instruction <|>
1307   LD-(NN),R-instruction <|>
1308   LD-RR,(NN)-instruction <|>
1309   LD-R,(NN)-instruction <|>
1310   ADC-R,N-instruction <|>
1311   ADC-R,R-instruction <|>
1312   ADC-R,(RR)-instruction <|>
1313   ADD-R,N-instruction <|>
1314   ADD-R,R-instruction <|>
1315   ADD-RR,RR-instruction <|>
1316   ADD-R,(RR)-instruction <|>
1317   SBC-R,N-instruction <|>
1318   SBC-R,R-instruction <|>
1319   SBC-R,(RR)-instruction <|>
1320   SUB-R-instruction <|>
1321   SUB-(RR)-instruction <|>
1322   SUB-N-instruction <|>
1323   RET-F|FF-instruction <|>
1324   RET-NN-instruction <|>
1325   OUT-(N),R-instruction <|>
1326   IN-R,(N)-instruction <|>
1327   EX-(RR),RR-instruction <|>
1328   EX-RR,RR-instruction <|>
1329   just ;
1330
1331 : instruction-quotations ( string -- emulate-quot )
1332   #! Given an instruction string, return the emulation quotation for
1333   #! it. This will later be expanded to produce the disassembly and
1334   #! assembly quotations.
1335   8080-generator-parser some parse force call ;
1336
1337 SYMBOL: last-instruction
1338 SYMBOL: last-opcode
1339
1340 : parse-instructions ( list -- emulate-quot )
1341   #! Process the list of strings, which should make
1342   #! up an 8080 instruction, and output a quotation
1343   #! that would implement that instruction.
1344   dup " " join instruction-quotations
1345   >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-hash
1346   r> define-compound ;
1347
1348 : INSTRUCTION: string-mode on [ string-mode off parse-instructions ] f ; parsing
1349
1350 : cycles ( -- )
1351   #! Set the number of cycles for the last instruction that was defined.
1352   scan string>number last-opcode global hash instruction-cycles set-nth ; parsing
1353
1354 : opcode ( -- )
1355   #! Set the opcode number for the last instruction that was defined.
1356   last-instruction global hash unit scan 16 base>
1357   dup last-opcode global set-hash instructions set-nth ; parsing
1358
1359 INSTRUCTION: NOP          ; opcode 00 cycles 04
1360 INSTRUCTION: LD   BC,nn   ; opcode 01 cycles 10
1361 INSTRUCTION: LD   (BC),A  ; opcode 02 cycles 07
1362 INSTRUCTION: INC  BC      ; opcode 03 cycles 06
1363 INSTRUCTION: INC  B       ; opcode 04 cycles 05
1364 INSTRUCTION: DEC  B       ; opcode 05 cycles 05
1365 INSTRUCTION: LD   B,n     ; opcode 06 cycles 07
1366 INSTRUCTION: RLCA         ; opcode 07 cycles 04
1367 INSTRUCTION: NOP          ; opcode 08 cycles 04
1368 INSTRUCTION: ADD  HL,BC   ; opcode 09 cycles 11
1369 INSTRUCTION: LD   A,(BC)  ; opcode 0A cycles 07
1370 INSTRUCTION: DEC  BC      ; opcode 0B cycles 06
1371 INSTRUCTION: INC  C       ; opcode 0C cycles 05
1372 INSTRUCTION: DEC  C       ; opcode 0D cycles 05
1373 INSTRUCTION: LD   C,n     ; opcode 0E cycles 07
1374 INSTRUCTION: RRCA         ; opcode 0F cycles 04
1375 INSTRUCTION: LD   DE,nn   ; opcode 11 cycles 10
1376 INSTRUCTION: LD   (DE),A  ; opcode 12 cycles 07
1377 INSTRUCTION: INC  DE      ; opcode 13 cycles 06
1378 INSTRUCTION: INC  D       ; opcode 14 cycles 05
1379 INSTRUCTION: DEC  D       ; opcode 15 cycles 05
1380 INSTRUCTION: LD   D,n     ; opcode 16 cycles 07
1381 INSTRUCTION: RLA          ; opcode 17 cycles 04
1382 INSTRUCTION: ADD  HL,DE   ; opcode 19 cycles 11
1383 INSTRUCTION: LD   A,(DE)  ; opcode 1A cycles 07
1384 INSTRUCTION: DEC  DE      ; opcode 1B cycles 06
1385 INSTRUCTION: INC  E       ; opcode 1C cycles 05
1386 INSTRUCTION: DEC  E       ; opcode 1D cycles 05
1387 INSTRUCTION: LD   E,n     ; opcode 1E cycles 07
1388 INSTRUCTION: RRA          ; opcode 1F cycles 04
1389 INSTRUCTION: LD   HL,nn   ; opcode 21 cycles 10
1390 INSTRUCTION: LD   (nn),HL ; opcode 22 cycles 16
1391 INSTRUCTION: INC  HL      ; opcode 23 cycles 06
1392 INSTRUCTION: INC  H       ; opcode 24 cycles 05
1393 INSTRUCTION: DEC  H       ; opcode 25 cycles 05
1394 INSTRUCTION: LD   H,n     ; opcode 26 cycles 07
1395 INSTRUCTION: DAA          ; opcode 27 cycles 04
1396 INSTRUCTION: ADD  HL,HL   ; opcode 29 cycles 11
1397 INSTRUCTION: LD   HL,(nn) ; opcode 2A cycles 16
1398 INSTRUCTION: DEC  HL      ; opcode 2B cycles 06
1399 INSTRUCTION: INC  L       ; opcode 2C cycles 05
1400 INSTRUCTION: DEC  L       ; opcode 2D cycles 05
1401 INSTRUCTION: LD   L,n     ; opcode 2E cycles 07
1402 INSTRUCTION: CPL          ; opcode 2F cycles 04
1403 INSTRUCTION: LD   SP,nn   ; opcode 31 cycles 10
1404 INSTRUCTION: LD   (nn),A  ; opcode 32 cycles 13
1405 INSTRUCTION: INC  SP      ; opcode 33 cycles 06
1406 INSTRUCTION: INC  (HL)    ; opcode 34 cycles 10
1407 INSTRUCTION: DEC  (HL)    ; opcode 35 cycles 10
1408 INSTRUCTION: LD   (HL),n  ; opcode 36 cycles 10
1409 INSTRUCTION: SCF          ; opcode 37 cycles 04
1410 INSTRUCTION: ADD  HL,SP   ; opcode 39 cycles 11
1411 INSTRUCTION: LD   A,(nn)  ; opcode 3A cycles 13
1412 INSTRUCTION: DEC  SP      ; opcode 3B cycles 06
1413 INSTRUCTION: INC  A       ; opcode 3C cycles 05
1414 INSTRUCTION: DEC  A       ; opcode 3D cycles 05
1415 INSTRUCTION: LD   A,n     ; opcode 3E cycles 07
1416 INSTRUCTION: CCF          ; opcode 3F cycles 04
1417 INSTRUCTION: LD   B,B     ; opcode 40 cycles 05
1418 INSTRUCTION: LD   B,C     ; opcode 41 cycles 05
1419 INSTRUCTION: LD   B,D     ; opcode 42 cycles 05
1420 INSTRUCTION: LD   B,E     ; opcode 43 cycles 05
1421 INSTRUCTION: LD   B,H     ; opcode 44 cycles 05
1422 INSTRUCTION: LD   B,L     ; opcode 45 cycles 05
1423 INSTRUCTION: LD   B,(HL)  ; opcode 46 cycles 07
1424 INSTRUCTION: LD   B,A     ; opcode 47 cycles 05
1425 INSTRUCTION: LD   C,B     ; opcode 48 cycles 05
1426 INSTRUCTION: LD   C,C     ; opcode 49 cycles 05
1427 INSTRUCTION: LD   C,D     ; opcode 4A cycles 05
1428 INSTRUCTION: LD   C,E     ; opcode 4B cycles 05
1429 INSTRUCTION: LD   C,H     ; opcode 4C cycles 05
1430 INSTRUCTION: LD   C,L     ; opcode 4D cycles 05
1431 INSTRUCTION: LD   C,(HL)  ; opcode 4E cycles 07
1432 INSTRUCTION: LD   C,A     ; opcode 4F cycles 05
1433 INSTRUCTION: LD   D,B     ; opcode 50 cycles 05
1434 INSTRUCTION: LD   D,C     ; opcode 51 cycles 05
1435 INSTRUCTION: LD   D,D     ; opcode 52 cycles 05
1436 INSTRUCTION: LD   D,E     ; opcode 53 cycles 05
1437 INSTRUCTION: LD   D,H     ; opcode 54 cycles 05
1438 INSTRUCTION: LD   D,L     ; opcode 55 cycles 05
1439 INSTRUCTION: LD   D,(HL)  ; opcode 56 cycles 07
1440 INSTRUCTION: LD   D,A     ; opcode 57 cycles 05
1441 INSTRUCTION: LD   E,B     ; opcode 58 cycles 05
1442 INSTRUCTION: LD   E,C     ; opcode 59 cycles 05
1443 INSTRUCTION: LD   E,D     ; opcode 5A cycles 05
1444 INSTRUCTION: LD   E,E     ; opcode 5B cycles 05
1445 INSTRUCTION: LD   E,H     ; opcode 5C cycles 05
1446 INSTRUCTION: LD   E,L     ; opcode 5D cycles 05
1447 INSTRUCTION: LD   E,(HL)  ; opcode 5E cycles 07
1448 INSTRUCTION: LD   E,A     ; opcode 5F cycles 05
1449 INSTRUCTION: LD   H,B     ; opcode 60 cycles 05
1450 INSTRUCTION: LD   H,C     ; opcode 61 cycles 05
1451 INSTRUCTION: LD   H,D     ; opcode 62 cycles 05
1452 INSTRUCTION: LD   H,E     ; opcode 63 cycles 05
1453 INSTRUCTION: LD   H,H     ; opcode 64 cycles 05
1454 INSTRUCTION: LD   H,L     ; opcode 65 cycles 05
1455 INSTRUCTION: LD   H,(HL)  ; opcode 66 cycles 07
1456 INSTRUCTION: LD   H,A     ; opcode 67 cycles 05
1457 INSTRUCTION: LD   L,B     ; opcode 68 cycles 05
1458 INSTRUCTION: LD   L,C     ; opcode 69 cycles 05
1459 INSTRUCTION: LD   L,D     ; opcode 6A cycles 05
1460 INSTRUCTION: LD   L,E     ; opcode 6B cycles 05
1461 INSTRUCTION: LD   L,H     ; opcode 6C cycles 05
1462 INSTRUCTION: LD   L,L     ; opcode 6D cycles 05
1463 INSTRUCTION: LD   L,(HL)  ; opcode 6E cycles 07
1464 INSTRUCTION: LD   L,A     ; opcode 6F cycles 05
1465 INSTRUCTION: LD   (HL),B  ; opcode 70 cycles 07
1466 INSTRUCTION: LD   (HL),C  ; opcode 71 cycles 07
1467 INSTRUCTION: LD   (HL),D  ; opcode 72 cycles 07
1468 INSTRUCTION: LD   (HL),E  ; opcode 73 cycles 07
1469 INSTRUCTION: LD   (HL),H  ; opcode 74 cycles 07
1470 INSTRUCTION: LD   (HL),L  ; opcode 75 cycles 07
1471 INSTRUCTION: HALT         ; opcode 76 cycles 07
1472 INSTRUCTION: LD   (HL),A  ; opcode 77 cycles 07
1473 INSTRUCTION: LD   A,B     ; opcode 78 cycles 05
1474 INSTRUCTION: LD   A,C     ; opcode 79 cycles 05
1475 INSTRUCTION: LD   A,D     ; opcode 7A cycles 05
1476 INSTRUCTION: LD   A,E     ; opcode 7B cycles 05
1477 INSTRUCTION: LD   A,H     ; opcode 7C cycles 05
1478 INSTRUCTION: LD   A,L     ; opcode 7D cycles 05
1479 INSTRUCTION: LD   A,(HL)  ; opcode 7E cycles 07
1480 INSTRUCTION: LD   A,A     ; opcode 7F cycles 05
1481 INSTRUCTION: ADD  A,B     ; opcode 80 cycles 04
1482 INSTRUCTION: ADD  A,C     ; opcode 81 cycles 04
1483 INSTRUCTION: ADD  A,D     ; opcode 82 cycles 04
1484 INSTRUCTION: ADD  A,E     ; opcode 83 cycles 04
1485 INSTRUCTION: ADD  A,H     ; opcode 84 cycles 04
1486 INSTRUCTION: ADD  A,L     ; opcode 85 cycles 04
1487 INSTRUCTION: ADD  A,(HL)  ; opcode 86 cycles 07
1488 INSTRUCTION: ADD  A,A     ; opcode 87 cycles 04
1489 INSTRUCTION: ADC  A,B     ; opcode 88 cycles 04
1490 INSTRUCTION: ADC  A,C     ; opcode 89 cycles 04
1491 INSTRUCTION: ADC  A,D     ; opcode 8A cycles 04
1492 INSTRUCTION: ADC  A,E     ; opcode 8B cycles 04
1493 INSTRUCTION: ADC  A,H     ; opcode 8C cycles 04
1494 INSTRUCTION: ADC  A,L     ; opcode 8D cycles 04
1495 INSTRUCTION: ADC  A,(HL)  ; opcode 8E cycles 07
1496 INSTRUCTION: ADC  A,A     ; opcode 8F cycles 04
1497 INSTRUCTION: SUB  B       ; opcode 90 cycles 04
1498 INSTRUCTION: SUB  C       ; opcode 91 cycles 04
1499 INSTRUCTION: SUB  D       ; opcode 92 cycles 04
1500 INSTRUCTION: SUB  E       ; opcode 93 cycles 04
1501 INSTRUCTION: SUB  H       ; opcode 94 cycles 04
1502 INSTRUCTION: SUB  L       ; opcode 95 cycles 04
1503 INSTRUCTION: SUB  (HL)    ; opcode 96 cycles 07
1504 INSTRUCTION: SUB  A       ; opcode 97 cycles 04
1505 INSTRUCTION: SBC  A,B     ; opcode 98 cycles 04
1506 INSTRUCTION: SBC  A,C     ; opcode 99 cycles 04
1507 INSTRUCTION: SBC  A,D     ; opcode 9A cycles 04
1508 INSTRUCTION: SBC  A,E     ; opcode 9B cycles 04
1509 INSTRUCTION: SBC  A,H     ; opcode 9C cycles 04
1510 INSTRUCTION: SBC  A,L     ; opcode 9D cycles 04
1511 INSTRUCTION: SBC  A,(HL)  ; opcode 9E cycles 07
1512 INSTRUCTION: SBC  A,A     ; opcode 9F cycles 04
1513 INSTRUCTION: AND  B       ; opcode A0 cycles 04
1514 INSTRUCTION: AND  C       ; opcode A1 cycles 04
1515 INSTRUCTION: AND  D       ; opcode A2 cycles 04
1516 INSTRUCTION: AND  E       ; opcode A3 cycles 04
1517 INSTRUCTION: AND  H       ; opcode A4 cycles 04
1518 INSTRUCTION: AND  L       ; opcode A5 cycles 04
1519 INSTRUCTION: AND  (HL)    ; opcode A6 cycles 07
1520 INSTRUCTION: AND  A       ; opcode A7 cycles 04
1521 INSTRUCTION: XOR  B       ; opcode A8 cycles 04
1522 INSTRUCTION: XOR  C       ; opcode A9 cycles 04
1523 INSTRUCTION: XOR  D       ; opcode AA cycles 04
1524 INSTRUCTION: XOR  E       ; opcode AB cycles 04
1525 INSTRUCTION: XOR  H       ; opcode AC cycles 04
1526 INSTRUCTION: XOR  L       ; opcode AD cycles 04
1527 INSTRUCTION: XOR  (HL)    ; opcode AE cycles 07
1528 INSTRUCTION: XOR  A       ; opcode AF cycles 04
1529 INSTRUCTION: OR   B       ; opcode B0 cycles 04
1530 INSTRUCTION: OR   C       ; opcode B1 cycles 04
1531 INSTRUCTION: OR   D       ; opcode B2 cycles 04
1532 INSTRUCTION: OR   E       ; opcode B3 cycles 04
1533 INSTRUCTION: OR   H       ; opcode B4 cycles 04
1534 INSTRUCTION: OR   L       ; opcode B5 cycles 04
1535 INSTRUCTION: OR   (HL)    ; opcode B6 cycles 07
1536 INSTRUCTION: OR   A       ; opcode B7 cycles 04
1537 INSTRUCTION: CP   B       ; opcode B8 cycles 04
1538 INSTRUCTION: CP   C       ; opcode B9 cycles 04
1539 INSTRUCTION: CP   D       ; opcode BA cycles 04
1540 INSTRUCTION: CP   E       ; opcode BB cycles 04
1541 INSTRUCTION: CP   H       ; opcode BC cycles 04
1542 INSTRUCTION: CP   L       ; opcode BD cycles 04
1543 INSTRUCTION: CP   (HL)    ; opcode BE cycles 07
1544 INSTRUCTION: CP   A       ; opcode BF cycles 04
1545 INSTRUCTION: RET  NZ      ; opcode C0 cycles 05
1546 INSTRUCTION: POP  BC      ; opcode C1 cycles 10
1547 INSTRUCTION: JP   NZ,nn   ; opcode C2 cycles 10
1548 INSTRUCTION: JP   nn      ; opcode C3 cycles 10
1549 INSTRUCTION: CALL NZ,nn   ; opcode C4 cycles 11
1550 INSTRUCTION: PUSH BC      ; opcode C5 cycles 11
1551 INSTRUCTION: ADD  A,n     ; opcode C6 cycles 07
1552 INSTRUCTION: RST  0       ; opcode C7 cycles 11
1553 INSTRUCTION: RET  Z       ; opcode C8 cycles 05
1554 INSTRUCTION: RET  nn      ; opcode C9 cycles 10
1555 INSTRUCTION: JP   Z,nn    ; opcode CA cycles 10
1556 INSTRUCTION: CALL Z,nn    ; opcode CC cycles 11
1557 INSTRUCTION: CALL nn      ; opcode CD cycles 17
1558 INSTRUCTION: ADC  A,n     ; opcode CE cycles 07
1559 INSTRUCTION: RST  8       ; opcode CF cycles 11
1560 INSTRUCTION: RET  NC      ; opcode D0 cycles 05
1561 INSTRUCTION: POP  DE      ; opcode D1 cycles 10
1562 INSTRUCTION: JP   NC,nn   ; opcode D2 cycles 10
1563 INSTRUCTION: OUT  (n),A   ; opcode D3 cycles 10
1564 INSTRUCTION: CALL NC,nn   ; opcode D4 cycles 11
1565 INSTRUCTION: PUSH DE      ; opcode D5 cycles 11
1566 INSTRUCTION: SUB  n       ; opcode D6 cycles 07
1567 INSTRUCTION: RST  10H     ; opcode D7 cycles 11
1568 INSTRUCTION: RET  C       ; opcode D8 cycles 05
1569 INSTRUCTION: JP   C,nn    ; opcode DA cycles 10
1570 INSTRUCTION: IN   A,(n)   ; opcode DB cycles 10
1571 INSTRUCTION: CALL C,nn    ; opcode DC cycles 11
1572 INSTRUCTION: SBC  A,n     ; opcode DE cycles 07
1573 INSTRUCTION: RST  18H     ; opcode DF cycles 11
1574 INSTRUCTION: RET  PO      ; opcode E0 cycles 05
1575 INSTRUCTION: POP  HL      ; opcode E1 cycles 10
1576 INSTRUCTION: JP   PO,nn   ; opcode E2 cycles 10
1577 INSTRUCTION: EX   (SP),HL ; opcode E3 cycles 04
1578 INSTRUCTION: CALL PO,nn   ; opcode E4 cycles 11
1579 INSTRUCTION: PUSH HL      ; opcode E5 cycles 11
1580 INSTRUCTION: AND  n       ; opcode E6 cycles 07
1581 INSTRUCTION: RST  20H     ; opcode E7 cycles 11
1582 INSTRUCTION: RET  PE      ; opcode E8 cycles 05
1583 INSTRUCTION: JP   (HL)    ; opcode E9 cycles 04
1584 INSTRUCTION: JP   PE,nn   ; opcode EA cycles 10
1585 INSTRUCTION: EX   DE,HL   ; opcode EB cycles 04
1586 INSTRUCTION: CALL PE,nn   ; opcode EC cycles 11
1587 INSTRUCTION: XOR  n       ; opcode EE cycles 07
1588 INSTRUCTION: RST  28H     ; opcode EF cycles 11
1589 INSTRUCTION: RET  P       ; opcode F0 cycles 05
1590 INSTRUCTION: POP  AF      ; opcode F1 cycles 10
1591 INSTRUCTION: JP   P,nn    ; opcode F2 cycles 10
1592 INSTRUCTION: DI           ; opcode F3 cycles 04
1593 INSTRUCTION: CALL P,nn    ; opcode F4 cycles 11
1594 INSTRUCTION: PUSH AF      ; opcode F5 cycles 11
1595 INSTRUCTION: OR   n       ; opcode F6 cycles 07
1596 INSTRUCTION: RST  30H     ; opcode F7 cycles 11
1597 INSTRUCTION: RET  M       ; opcode F8 cycles 05
1598 INSTRUCTION: LD   SP,HL   ; opcode F9 cycles 06
1599 INSTRUCTION: JP   M,nn    ; opcode FA cycles 10
1600 INSTRUCTION: EI           ; opcode FB cycles 04
1601 INSTRUCTION: CALL M,nn    ; opcode FC cycles 11
1602 INSTRUCTION: CP   n       ; opcode FE cycles 07
1603 INSTRUCTION: RST  38H     ; opcode FF cycles 11
1604
1605 : each-8bit ( n quot -- )
1606   8 [ ! n quot bit
1607    pick over -1 * shift 1 bitand pick call
1608   ] repeat 2drop ;
1609
1610 : >ppm ( cpu filename -- cpu )
1611   #! Dump the current screen image to a ppm image file with the given name.
1612   <file-writer> [
1613     "P3" print
1614     "256 224" print
1615     "1" print
1616     224 [
1617       32 [
1618         over 32 * over +  HEX: 2400 + ! cpu h w addr
1619         >r pick r> swap cpu-ram nth [
1620           0 = [
1621             " 0 0 0" write
1622           ] [
1623             " 1 1 1" write
1624           ] if
1625         ] each-8bit
1626       ] repeat terpri
1627     ] repeat
1628   ] with-stream ;
1629
1630 USE: test
1631 : time-test ( -- )
1632   test-cpu [ 1000000 run-n ] time ;
1633