extra/cpu/8080/emulator/emulator.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 USING: kernel math sequences words arrays io io.files namespaces
   5 math.parser assocs quotations parser parser-combinators
   6 tools.time io.encodings.binary ;
   7 IN: cpu.8080.emulator
   8
   9 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
  10
  11 GENERIC: reset        ( cpu            -- )
  12 GENERIC: update-video ( value addr cpu -- )
  13 GENERIC: read-port    ( port cpu       -- byte )
  14 GENERIC: write-port   ( value port cpu -- )
  15
  16 M: cpu update-video ( value addr cpu -- )
  17   3drop ;
  18
  19 M: cpu read-port ( port cpu -- byte )
  20   #! Read a byte from the hardware port. 'port' should
  21   #! be an 8-bit value.
  22   2drop 0 ;
  23
  24 M: cpu write-port ( value port cpu -- )
  25   #! Write a byte to the hardware port, where 'port' is
  26   #! an 8-bit value.
  27   3drop ;
  28
  29 : carry-flag        HEX: 01 ; inline
  30 : parity-flag       HEX: 04 ; inline
  31 : half-carry-flag   HEX: 10 ; inline
  32 : interrupt-flag    HEX: 20 ; inline
  33 : zero-flag         HEX: 40 ; inline
  34 : sign-flag         HEX: 80 ; inline
  35
  36 : >word< ( word -- byte byte )
  37   #! Explode a word into its two 8 bit values.
  38   dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
  39
  40 : cpu-af ( cpu -- word )
  41   #! Return the 16-bit pseudo register AF.
  42   [ cpu-a 8 shift ] keep cpu-f bitor ;
  43
  44 : set-cpu-af ( value cpu -- )
  45   #! Set the value of the 16-bit pseudo register AF
  46   >r >word< r> tuck set-cpu-f set-cpu-a ;
  47
  48 : cpu-bc ( cpu -- word )
  49   #! Return the 16-bit pseudo register BC.
  50   [ cpu-b 8 shift ] keep cpu-c bitor ;
  51
  52 : set-cpu-bc ( value cpu -- )
  53   #! Set the value of the 16-bit pseudo register BC
  54   >r >word< r> tuck set-cpu-c set-cpu-b ;
  55
  56 : cpu-de ( cpu -- word )
  57   #! Return the 16-bit pseudo register DE.
  58   [ cpu-d 8 shift ] keep cpu-e bitor ;
  59
  60 : set-cpu-de ( value cpu -- )
  61   #! Set the value of the 16-bit pseudo register DE
  62   >r >word< r> tuck set-cpu-e set-cpu-d ;
  63
  64 : cpu-hl ( cpu -- word )
  65   #! Return the 16-bit pseudo register HL.
  66   [ cpu-h 8 shift ] keep cpu-l bitor ;
  67
  68 : set-cpu-hl ( value cpu -- )
  69   #! Set the value of the 16-bit pseudo register HL
  70   >r >word< r> tuck set-cpu-l set-cpu-h ;
  71
  72 : flag-set? ( flag cpu -- bool )
  73   cpu-f bitand 0 = not ;
  74
  75 : flag-clear? ( flag cpu -- bool )
  76   cpu-f bitand 0 = ;
  77
  78 : flag-nz? ( cpu -- bool )
  79   #! Test flag status
  80   cpu-f zero-flag bitand 0 = ;
  81
  82 : flag-z? ( cpu -- bool )
  83   #! Test flag status
  84   cpu-f zero-flag bitand 0 = not ;
  85
  86 : flag-nc? ( cpu -- bool )
  87   #! Test flag status
  88   cpu-f carry-flag bitand 0 = ;
  89
  90 : flag-c? ( cpu -- bool )
  91   #! Test flag status
  92   cpu-f carry-flag bitand 0 = not ;
  93
  94 : flag-po? ( cpu -- bool )
  95   #! Test flag status
  96   cpu-f parity-flag bitand 0 =  ;
  97
  98 : flag-pe? ( cpu -- bool )
  99   #! Test flag status
 100   cpu-f parity-flag bitand 0 = not ;
 101
 102 : flag-p? ( cpu -- bool )
 103   #! Test flag status
 104   cpu-f sign-flag bitand 0 = ;
 105
 106 : flag-m? ( cpu -- bool )
 107   #! Test flag status
 108   cpu-f sign-flag bitand 0 = not ;
 109
 110 : read-byte ( addr cpu -- byte )
 111   #! Read one byte from memory at the specified address.
 112   #! The address is 16-bit, but if a value greater than
 113   #! 0xFFFF is provided then return a default value.
 114   over HEX: FFFF <= [
 115     cpu-ram nth
 116   ] [
 117     2drop HEX: FF
 118   ] if ;
 119
 120 : read-word ( addr cpu -- word )
 121   #! Read a 16-bit word from memory at the specified address.
 122   #! The address is 16-bit, but if a value greater than
 123   #! 0xFFFF is provided then return a default value.
 124   [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
 125
 126 : next-byte ( cpu -- byte )
 127   #! Return the value of the byte at PC, and increment PC.
 128   [ cpu-pc ] keep
 129   [ read-byte ] keep
 130   [ cpu-pc 1 + ] keep
 131   set-cpu-pc ;
 132
 133 : next-word ( cpu -- word )
 134   #! Return the value of the word at PC, and increment PC.
 135   [ cpu-pc ] keep
 136   [ read-word ] keep
 137   [ cpu-pc 2 + ] keep
 138   set-cpu-pc ;
 139
 140
 141 : write-byte ( value addr cpu -- )
 142   #! Write a byte to the specified memory address.
 143   over dup HEX: 2000 < swap HEX: FFFF > or [
 144     3drop
 145   ] [
 146     3dup cpu-ram set-nth
 147     update-video
 148   ] if ;
 149
 150
 151 : write-word ( value addr cpu -- )
 152   #! Write a 16-bit word to the specified memory address.
 153   >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
 154
 155 : cpu-a-bitand ( quot cpu -- )
 156   #! A &= quot call
 157   [ cpu-a swap call bitand ] keep set-cpu-a ; inline
 158
 159 : cpu-a-bitor ( quot cpu -- )
 160   #! A |= quot call
 161   [ cpu-a swap call bitor ] keep set-cpu-a ; inline
 162
 163 : cpu-a-bitxor ( quot cpu -- )
 164   #! A ^= quot call
 165   [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
 166
 167 : cpu-a-bitxor= ( value cpu -- )
 168   #! cpu-a ^= value
 169   [ cpu-a bitxor ] keep set-cpu-a ;
 170
 171 : cpu-f-bitand ( quot cpu -- )
 172   #! F &= quot call
 173   [ cpu-f swap call bitand ] keep set-cpu-f ; inline
 174
 175 : cpu-f-bitor ( quot cpu -- )
 176   #! F |= quot call
 177   [ cpu-f swap call bitor ] keep set-cpu-f ; inline
 178
 179 : cpu-f-bitxor ( quot cpu -- )
 180   #! F |= quot call
 181   [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
 182
 183 : cpu-f-bitor= ( value cpu -- )
 184   #! cpu-f |= value
 185   [ cpu-f bitor ] keep set-cpu-f ;
 186
 187 : cpu-f-bitand= ( value cpu -- )
 188   #! cpu-f &= value
 189   [ cpu-f bitand ] keep set-cpu-f ;
 190
 191 : cpu-f-bitxor= ( value cpu -- )
 192   #! cpu-f ^= value
 193   [ cpu-f bitxor ] keep set-cpu-f ;
 194
 195 : set-flag ( cpu flag -- )
 196   swap cpu-f-bitor= ;
 197
 198 : clear-flag ( cpu flag -- )
 199    bitnot HEX: FF bitand swap cpu-f-bitand= ;
 200
 201 : update-zero-flag ( result cpu -- )
 202   #! If the result of an instruction has the value 0, this
 203   #! flag is set, otherwise it is reset.
 204   swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
 205
 206 : update-sign-flag ( result cpu -- )
 207   #! If the most significant bit of the result
 208   #! has the value 1 then the flag is set, otherwise
 209   #! it is reset.
 210   swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
 211
 212 : update-parity-flag ( result cpu -- )
 213   #! If the modulo 2 sum of the bits of the result
 214   #! is 0, (ie. if the result has even parity) this flag
 215   #! is set, otherwise it is reset.
 216   swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
 217
 218 : update-carry-flag ( result cpu -- )
 219   #! If the instruction resulted in a carry (from addition)
 220   #! or a borrow (from subtraction or a comparison) out of the
 221   #! higher order bit, this flag is set, otherwise it is reset.
 222   swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
 223
 224 : update-half-carry-flag ( original change-by result cpu -- )
 225   #! If the instruction caused a carry out of bit 3 and into bit 4 of the
 226   #! resulting value, the half carry flag is set, otherwise it is reset.
 227   #! The 'original' is the original value of the register being changed.
 228   #! 'change-by' is the amount it is being added or decremented by.
 229   #! 'result' is the result of that change.
 230   >r bitxor bitxor HEX: 10 bitand 0 = not r>
 231   swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
 232
 233 : update-flags ( result cpu -- )
 234   2dup update-carry-flag
 235   2dup update-parity-flag
 236   2dup update-sign-flag
 237   update-zero-flag ;
 238
 239 : update-flags-no-carry ( result cpu -- )
 240   2dup update-parity-flag
 241   2dup update-sign-flag
 242   update-zero-flag ;
 243
 244 : add-byte ( lhs rhs cpu -- result )
 245   #! Add rhs to lhs
 246   >r 2dup + r> ! lhs rhs result cpu
 247   [ update-flags ] 2keep
 248   [ update-half-carry-flag ] 2keep
 249   drop HEX: FF bitand ;
 250
 251 : add-carry ( change-by result cpu -- change-by result )
 252   #! Add the effect of the carry flag to the result
 253   flag-c? [ 1 + >r 1 + r> ] when ;
 254
 255 : add-byte-with-carry ( lhs rhs cpu -- result )
 256   #! Add rhs to lhs plus carry.
 257   >r 2dup + r> ! lhs rhs result cpu
 258   [ add-carry ] keep
 259   [ update-flags ] 2keep
 260   [ update-half-carry-flag ] 2keep
 261   drop HEX: FF bitand ;
 262
 263 : sub-carry ( change-by result cpu -- change-by result )
 264   #! Subtract the effect of the carry flag from the result
 265   flag-c? [ 1 - >r 1 - r>  ] when ;
 266
 267 : sub-byte ( lhs rhs cpu -- result )
 268   #! Subtract rhs from lhs
 269   >r 2dup - r>
 270   [ update-flags ] 2keep
 271   [ update-half-carry-flag ] 2keep
 272   drop HEX: FF bitand ;
 273
 274 : sub-byte-with-carry ( lhs rhs cpu -- result )
 275   #! Subtract rhs from lhs and take carry into account
 276   >r 2dup - r>
 277   [ sub-carry ] keep
 278   [ update-flags ] 2keep
 279   [ update-half-carry-flag ] 2keep
 280   drop HEX: FF bitand ;
 281
 282 : inc-byte ( byte cpu -- result )
 283   #! Increment byte by one. Note that carry flag is not affected
 284   #! by this operation.
 285   >r 1 2dup + r> ! lhs rhs result cpu
 286   [ update-flags-no-carry ] 2keep
 287   [ update-half-carry-flag ] 2keep
 288   drop HEX: FF bitand ;
 289
 290 : dec-byte ( byte cpu -- result )
 291   #! Decrement byte by one. Note that carry flag is not affected
 292   #! by this operation.
 293   >r 1 2dup - r> ! lhs rhs result cpu
 294   [ update-flags-no-carry ] 2keep
 295   [ update-half-carry-flag ] 2keep
 296   drop HEX: FF bitand ;
 297
 298 : inc-word ( w cpu -- w )
 299   #! Increment word by one. Note that no flags are modified.
 300   drop 1 + HEX: FFFF bitand ;
 301
 302 : dec-word ( w cpu -- w )
 303   #! Decrement word by one. Note that no flags are modified.
 304   drop 1 - HEX: FFFF bitand ;
 305
 306 : add-word ( lhs rhs cpu -- result )
 307   #! Add rhs to lhs. Note that only the carry flag is modified
 308   #! and only if there is a carry out of the double precision add.
 309   >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
 310
 311 : bit3or ( lhs rhs -- 0|1 )
 312   #! bitor bit 3 of the two numbers on the stack
 313   BIN: 00001000 bitand -3 shift >r
 314   BIN: 00001000 bitand -3 shift r>
 315   bitor ;
 316
 317 : and-byte ( lhs rhs cpu -- result )
 318   #! Logically and rhs to lhs. The carry flag is cleared and
 319   #! the half carry is set to the ORing of bits 3 of the operands.
 320   [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
 321   >r bitand r> [ update-flags ] 2keep
 322   [ carry-flag clear-flag ] keep
 323   rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
 324   HEX: FF bitand ;
 325
 326 : xor-byte ( lhs rhs cpu -- result )
 327   #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
 328   >r bitxor r> [ update-flags ] 2keep
 329   [ half-carry-flag carry-flag bitor clear-flag ] keep
 330   drop HEX: FF bitand ;
 331
 332 : or-byte ( lhs rhs cpu -- result )
 333   #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
 334   >r bitor r> [ update-flags ] 2keep
 335   [ half-carry-flag carry-flag bitor clear-flag ] keep
 336   drop HEX: FF bitand ;
 337
 338 : flags ( seq -- seq )
 339   [ 0 [ execute bitor ] reduce ] map ;
 340
 341 : decrement-sp ( n cpu -- )
 342   #! Decrement the stackpointer by n.
 343   [ cpu-sp ] keep
 344   >r swap - r> set-cpu-sp ;
 345
 346 : save-pc ( cpu -- )
 347   #! Save the value of the PC on the stack.
 348   [ cpu-pc ] keep ! pc cpu
 349   [ cpu-sp ] keep ! pc sp cpu
 350   write-word ;
 351
 352 : push-pc ( cpu -- )
 353   #! Push the value of the PC on the stack.
 354   2 over decrement-sp
 355   save-pc ;
 356
 357 : pop-pc ( cpu -- pc )
 358   #! Pop the value of the PC off the stack.
 359   [ cpu-sp ] keep
 360   [ read-word ] keep
 361   -2 swap decrement-sp ;
 362
 363 : push-sp ( value cpu -- )
 364   [ 2 swap decrement-sp ] keep
 365   [ cpu-sp ] keep
 366   write-word ;
 367
 368 : pop-sp ( cpu -- value )
 369   [ cpu-sp ] keep
 370   [ read-word ] keep
 371   -2 swap decrement-sp ;
 372
 373 : call-sub ( addr cpu -- )
 374   #! Call the address as a subroutine.
 375   dup push-pc
 376   >r HEX: FFFF bitand r> set-cpu-pc ;
 377
 378 : ret-from-sub ( cpu -- )
 379   [ pop-pc ] keep set-cpu-pc ;
 380
 381 : interrupt ( number cpu -- )
 382   #! Perform a hardware interrupt
 383 !  "***Interrupt: " write over 16 >base print
 384   dup cpu-f interrupt-flag bitand 0 = not [
 385     dup push-pc
 386     set-cpu-pc
 387   ] [
 388     2drop
 389   ] if ;
 390
 391 : inc-cycles ( n cpu -- )
 392   #! Increment the number of cpu cycles
 393   [ cpu-cycles + ] keep set-cpu-cycles ;
 394
 395 : instruction-cycles ( -- vector )
 396   #! Return a 256 element vector containing the cycles for
 397   #! each opcode in the 8080 instruction set.
 398   << 256 f <array> parsed >> ;
 399
 400 : not-implemented ( <cpu> -- )
 401   drop ;
 402
 403 : instructions ( -- vector )
 404   #! Return a 256 element vector containing the emulation words for
 405   #! each opcode in the 8080 instruction set.
 406   << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
 407
 408 : set-instruction ( quot n -- )
 409   tuck >r 2array r> instructions set-nth ;
 410
 411 M: cpu reset ( cpu -- )
 412   #! Reset the CPU to its poweron state
 413   [ 0 swap set-cpu-b  ] keep
 414   [ 0 swap set-cpu-c  ] keep
 415   [ 0 swap set-cpu-d  ] keep
 416   [ 0 swap set-cpu-e  ] keep
 417   [ 0 swap set-cpu-h  ] keep
 418   [ 0 swap set-cpu-l  ] keep
 419   [ 0 swap set-cpu-a  ] keep
 420   [ 0 swap set-cpu-f  ] keep
 421   [ 0 swap set-cpu-pc  ] keep
 422   [ HEX: F000 swap set-cpu-sp  ] keep
 423   [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
 424   [ f swap set-cpu-halted? ] keep
 425   [ HEX: 10 swap set-cpu-last-interrupt ] keep
 426   0 swap set-cpu-cycles ;
 427
 428 : <cpu> ( -- cpu ) cpu new dup reset ;
 429
 430 : (load-rom) ( n ram -- )
 431   read1 [ ! n ram ch
 432     -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
 433   ] [
 434     2drop
 435   ] if* ;
 436
 437   #! Reads the ROM from stdin and stores it in ROM from
 438   #! offset n.
 439 : load-rom ( filename cpu -- )
 440   #! Load the contents of the file into ROM.
 441   #! (address 0x0000-0x1FFF).
 442   cpu-ram swap binary [
 443     0 swap (load-rom)
 444   ] with-file-reader ;
 445
 446 SYMBOL: rom-root
 447
 448 : rom-dir ( -- string )
 449   rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
 450
 451 : load-rom* ( seq cpu -- )
 452   #! 'seq' is an array of arrays. Each array contains
 453   #! an address and filename of a ROM file. The ROM
 454   #! file will be loaded at the specified address. This
 455   #! file path shoul dbe relative to the '/roms' resource path.
 456   rom-dir [
 457     cpu-ram [
 458       swap first2 rom-dir prepend-path binary [
 459         swap (load-rom)
 460       ] with-file-reader
 461     ] curry each
 462   ] [
 463     !
 464     ! the ROM files.
 465     "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
 466   ] if ;
 467
 468 : read-instruction ( cpu -- word )
 469   #! Read the next instruction from the cpu's program
 470   #! counter, and increment the program counter.
 471   [ cpu-pc ] keep ! pc cpu
 472   [ over 1 + swap set-cpu-pc ] keep
 473   read-byte ;
 474
 475 : get-cycles ( n -- opcode )
 476   #! Returns the cycles for the given instruction value.
 477   #! If the opcode is not defined throw an error.
 478   dup instruction-cycles nth [
 479     nip
 480   ] [
 481     [ "Undefined 8080 opcode: " % number>string % ] "" make throw
 482   ] if* ;
 483
 484 : process-interrupts ( cpu -- )
 485   #! Process any hardware interrupts
 486   [ cpu-cycles ] keep
 487   over 16667 < [
 488     2drop
 489   ] [
 490     [ >r 16667 - r> set-cpu-cycles ] keep
 491     dup cpu-last-interrupt HEX: 10 = [
 492       HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
 493     ] [
 494       HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
 495     ] if
 496   ] if ;
 497
 498 : peek-instruction ( cpu -- word )
 499   #! Return the next instruction from the cpu's program
 500   #! counter, but don't increment the counter.
 501   [ cpu-pc ] keep read-byte instructions nth first ;
 502
 503 : cpu. ( cpu -- )
 504   [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
 505   [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
 506   [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
 507   [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
 508   [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
 509   [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
 510   [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
 511   [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
 512   [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
 513   [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
 514   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
 515   [ " " write peek-instruction word-name write " " write ] keep
 516   nl drop ;
 517
 518 : cpu*. ( cpu -- )
 519   [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
 520   [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
 521   [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
 522   [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
 523   [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
 524   [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
 525   [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
 526   [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
 527   [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
 528   [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
 529   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
 530   nl drop ;
 531
 532 : register-lookup ( string -- vector )
 533   #! Given a string containing a register name, return a vector
 534   #! where the 1st item is the getter and the 2nd is the setter
 535   #! for that register.
 536   H{
 537     { "A"  { cpu-a  set-cpu-a  } }
 538     { "B"  { cpu-b  set-cpu-b  } }
 539     { "C"  { cpu-c  set-cpu-c  } }
 540     { "D"  { cpu-d  set-cpu-d  } }
 541     { "E"  { cpu-e  set-cpu-e  } }
 542     { "H"  { cpu-h  set-cpu-h  } }
 543     { "L"  { cpu-l  set-cpu-l  } }
 544     { "AF" { cpu-af set-cpu-af } }
 545     { "BC" { cpu-bc set-cpu-bc } }
 546     { "DE" { cpu-de set-cpu-de } }
 547     { "HL" { cpu-hl set-cpu-hl } }
 548     { "SP" { cpu-sp set-cpu-sp } }
 549   } at ;
 550
 551
 552 : flag-lookup ( string -- vector )
 553   #! Given a string containing a flag name, return a vector
 554   #! where the 1st item is a word that tests that flag.
 555   H{
 556     { "NZ"  { flag-nz?  } }
 557     { "NC"  { flag-nc?  } }
 558     { "PO"  { flag-po?  } }
 559     { "PE"  { flag-pe?  } }
 560     { "Z"  { flag-z?  } }
 561     { "C"  { flag-c? } }
 562     { "P"  { flag-p?  } }
 563     { "M" { flag-m?  } }
 564   } at ;
 565
 566 SYMBOL: $1
 567 SYMBOL: $2
 568 SYMBOL: $3
 569 SYMBOL: $4
 570
 571 : replace-patterns ( vector tree -- tree )
 572   #! Copy the tree, replacing each occurence of
 573   #! $1, $2, etc with the relevant item from the
 574   #! given index.
 575   dup quotation? over [ ] = not and [ ! vector tree
 576     dup first swap rest ! vector car cdr
 577     >r dupd replace-patterns ! vector v R: cdr
 578     swap r> replace-patterns >r 1quotation r> append
 579   ] [ ! vector value
 580     dup $1 = [ drop 0 over nth  ] when
 581     dup $2 = [ drop 1 over nth  ] when
 582     dup $3 = [ drop 2 over nth  ] when
 583     dup $4 = [ drop 3 over nth  ] when
 584     nip
 585   ] if ;
 586
 587 : test-rp
 588   { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
 589
 590 : (emulate-RST) ( n cpu -- )
 591   #! RST nn
 592   [ cpu-sp 2 - dup ] keep ! sp sp cpu
 593   [ set-cpu-sp ] keep ! sp cpu
 594   [ cpu-pc ] keep ! sp pc cpu
 595   swapd [ write-word ] keep ! cpu
 596   >r 8 * r> set-cpu-pc ;
 597
 598 : (emulate-CALL) ( cpu -- )
 599   #! 205 - CALL nn
 600   [ next-word HEX: FFFF bitand ] keep ! addr cpu
 601   [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
 602   [ set-cpu-sp ] keep ! addr sp cpu
 603   [ cpu-pc ] keep ! addr sp pc cpu
 604   swapd [ write-word ] keep ! addr cpu
 605   set-cpu-pc ;
 606
 607 : (emulate-RLCA) ( cpu -- )
 608   #! The content of the accumulator is rotated left
 609   #! one position. The low order bit and the carry flag
 610   #! are both set to the value shifd out of the high
 611   #! order bit position. Only the carry flag is affected.
 612   [ cpu-a -7 shift ] keep
 613   over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 614   [ cpu-a 1 shift HEX: FF bitand ] keep
 615   >r bitor r> set-cpu-a ;
 616
 617 : (emulate-RRCA) ( cpu -- )
 618   #! The content of the accumulator is rotated right
 619   #! one position. The high order bit and the carry flag
 620   #! are both set to the value shifd out of the low
 621   #! order bit position. Only the carry flag is affected.
 622   [ cpu-a 1 bitand 7 shift ] keep
 623   over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 624   [ cpu-a 254 bitand -1 shift ] keep
 625   >r bitor r> set-cpu-a ;
 626
 627 : (emulate-RLA) ( cpu -- )
 628   #! The content of the accumulator is rotated left
 629   #! one position through the carry flag. The low
 630   #! order bit is set equal to the carry flag and
 631   #! the carry flag is set to the value shifd out
 632   #! of the high order bit. Only the carry flag is
 633   #! affected.
 634   [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
 635   [ cpu-a 127 bitand 7 shift ] keep
 636   dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 637   >r bitor r> set-cpu-a ;
 638
 639 : (emulate-RRA) ( cpu -- )
 640   #! The content of the accumulator is rotated right
 641   #! one position through the carry flag. The high order
 642   #! bit is set to the carry flag and the carry flag is
 643   #! set to the value shifd out of the low order bit.
 644   #! Only the carry flag is affected.
 645   [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
 646   [ cpu-a 254 bitand -1 shift ] keep
 647   dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
 648   >r bitor r> set-cpu-a ;
 649
 650 : (emulate-CPL) ( cpu -- )
 651   #! The contents of the accumulator are complemented
 652   #! (zero bits become one, one bits becomes zero).
 653   #! No flags are affected.
 654   HEX: FF swap cpu-a-bitxor= ;
 655
 656 : (emulate-DAA) ( cpu -- )
 657   #! The eight bit number in the accumulator is
 658   #! adjusted to form two four-bit binary-coded-decimal
 659   #! digits.
 660   [
 661     dup half-carry-flag swap flag-set? swap
 662     cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
 663   ] keep
 664   [ cpu-a + ] keep
 665   [ update-flags ] 2keep
 666   [ swap HEX: FF bitand swap set-cpu-a ] keep
 667   [
 668     dup carry-flag swap flag-set? swap
 669     cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
 670   ] keep
 671   [ cpu-a + ] keep
 672   [ update-flags ] 2keep
 673   swap HEX: FF bitand swap set-cpu-a ;
 674
 675 : patterns ( -- hashtable )
 676   #! table of code quotation patterns for each type of instruction.
 677   H{
 678     { "NOP"          [ drop ]               }
 679     { "RET-NN"          [ ret-from-sub  ]               }
 680     { "RST-0"      [ 0 swap (emulate-RST) ] }
 681     { "RST-8"      [ 8 swap (emulate-RST) ] }
 682     { "RST-10H"      [ HEX: 10 swap (emulate-RST) ] }
 683     { "RST-18H"      [ HEX: 18 swap (emulate-RST) ] }
 684     { "RST-20H"      [ HEX: 20 swap (emulate-RST) ] }
 685     { "RST-28H"      [ HEX: 28 swap (emulate-RST) ] }
 686     { "RST-30H"      [ HEX: 30 swap (emulate-RST) ] }
 687     { "RST-38H"      [ HEX: 38 swap (emulate-RST) ] }
 688     { "RET-F|FF"      [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
 689     { "CP-N"      [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
 690     { "CP-R"      [ [ cpu-a ] keep [ $1 ] keep sub-byte drop  ] }
 691     { "CP-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
 692     { "OR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
 693     { "OR-R"      [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
 694     { "OR-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a  ] }
 695     { "XOR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
 696     { "XOR-R"      [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
 697     { "XOR-(RR)"   [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a  ] }
 698     { "AND-N"      [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a  ] }
 699     { "AND-R"      [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
 700     { "AND-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a  ] }
 701     { "ADC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
 702     { "ADC-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
 703     { "ADC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
 704     { "ADD-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
 705     { "ADD-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
 706     { "ADD-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
 707     { "ADD-R,(RR)"    [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2   ]  }
 708     { "SBC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
 709     { "SBC-R,R"      [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
 710     { "SBC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
 711     { "SUB-R"      [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
 712     { "SUB-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
 713     { "SUB-N"      [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
 714     { "CPL"          [ (emulate-CPL) ]               }
 715     { "DAA"          [ (emulate-DAA) ]               }
 716     { "RLA"          [ (emulate-RLA) ]               }
 717     { "RRA"          [ (emulate-RRA) ]               }
 718     { "CCF"          [ carry-flag swap cpu-f-bitxor= ]               }
 719     { "SCF"          [ carry-flag swap cpu-f-bitor= ]               }
 720     { "RLCA"          [ (emulate-RLCA) ]               }
 721     { "RRCA"          [ (emulate-RRCA) ]               }
 722     { "HALT"          [ drop  ]               }
 723     { "DI"          [ [ 255 interrupt-flag - ] swap cpu-f-bitand  ]               }
 724     { "EI"          [ [ interrupt-flag ] swap cpu-f-bitor  ]  }
 725     { "POP-RR"     [ [ pop-sp ] keep $2 ] }
 726     { "PUSH-RR"     [ [ $1 ] keep push-sp ] }
 727     { "INC-R"     [ [ $1 ] keep [ inc-byte ] keep $2 ] }
 728     { "DEC-R"     [ [ $1 ] keep [ dec-byte ] keep $2 ] }
 729     { "INC-RR"     [ [ $1 ] keep [ inc-word ] keep $2 ] }
 730     { "DEC-RR"     [ [ $1 ] keep [ dec-word ] keep $2 ] }
 731     { "DEC-(RR)"     [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
 732     { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep  [ $1 ] keep write-byte ] }
 733     { "JP-NN"           [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ]               }
 734     { "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 ] }
 735     { "JP-(RR)"      [ [ $1 ] keep set-cpu-pc ] }
 736     { "CALL-NN"         [ (emulate-CALL) ] }
 737     { "CALL-F|FF,NN"    [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ]   }
 738     { "LD-RR,NN"     [ [ next-word ] keep $2 ] }
 739     { "LD-RR,RR"     [ [ $3 ] keep $2 ] }
 740     { "LD-R,N"     [ [ next-byte ] keep $2 ] }
 741     { "LD-(RR),N"    [ [ next-byte ] keep [ $1 ] keep write-byte ] }
 742     { "LD-(RR),R"    [ [ $3 ] keep [ $1 ] keep write-byte ] }
 743     { "LD-R,R"    [ [ $3 ] keep $2 ] }
 744     { "LD-R,(RR)"    [ [ $3 ] keep [ read-byte ] keep $2  ] }
 745     { "LD-(NN),RR"    [ [ $1 ] keep [ next-word ] keep write-word ] }
 746     { "LD-(NN),R"    [  [ $1 ] keep [ next-word ] keep write-byte ] }
 747     { "LD-RR,(NN)"    [ [ next-word ] keep [ read-word ] keep $2 ]  }
 748     { "LD-R,(NN)"    [ [ next-word ] keep [ read-byte ] keep $2 ] }
 749     { "OUT-(N),R"    [ [ $1 ] keep [ next-byte ] keep write-port ] }
 750     { "IN-R,(N)"    [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
 751     { "EX-(RR),RR"  [  [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
 752     { "EX-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
 753   } ;
 754
 755 : 8-bit-registers ( -- parser )
 756   #! A parser for 8-bit registers. On a successfull parse the
 757   #! parse tree contains a vector. The first item in the vector
 758   #! is the getter word for that register with stack effect
 759   #! ( cpu -- value ). The second item is the setter word with
 760   #! stack effect ( value cpu -- ).
 761   "A" token
 762   "B" token  <|>
 763   "C" token  <|>
 764   "D" token  <|>
 765   "E" token  <|>
 766   "H" token  <|>
 767   "L" token  <|> [ register-lookup ] <@ ;
 768
 769 : all-flags
 770   #! A parser for 16-bit flags.
 771   "NZ" token
 772   "NC" token <|>
 773   "PO" token <|>
 774   "PE" token <|>
 775   "Z" token <|>
 776   "C" token <|>
 777   "P" token <|>
 778   "M" token <|> [ flag-lookup ] <@ ;
 779
 780 : 16-bit-registers
 781   #! A parser for 16-bit registers. On a successfull parse the
 782   #! parse tree contains a vector. The first item in the vector
 783   #! is the getter word for that register with stack effect
 784   #! ( cpu -- value ). The second item is the setter word with
 785   #! stack effect ( value cpu -- ).
 786   "AF" token
 787   "BC" token <|>
 788   "DE" token <|>
 789   "HL" token <|>
 790   "SP" token <|> [ register-lookup ] <@ ;
 791
 792 : all-registers ( -- parser )
 793   #! Return a parser that can parse the format
 794   #! for 8 bit or 16 bit registers.
 795   8-bit-registers 16-bit-registers <|> ;
 796
 797 : indirect ( parser -- parser )
 798   #! Given a parser, return a parser which parses the original
 799   #! wrapped in brackets, representing an indirect reference.
 800   #! eg. BC -> (BC). The value of the original parser is left in
 801   #! the parse tree.
 802   "(" token swap &> ")" token <& ;
 803
 804 : generate-instruction ( vector string -- quot )
 805   #! Generate the quotation for an instruction, given the instruction in
 806   #! the 'string' and a vector containing the arguments for that instruction.
 807   patterns at replace-patterns ;
 808
 809 : simple-instruction ( token -- parser )
 810   #! Return a parser for then instruction identified by the token.
 811   #! The parser return parses the token only and expects no additional
 812   #! arguments to the instruction.
 813   token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
 814
 815 : complex-instruction ( type token -- parser )
 816   #! Return a parser for an instruction identified by the token.
 817   #! The instruction is expected to take additional arguments by
 818   #! being combined with other parsers. Then 'type' is used for a lookup
 819   #! in a pattern hashtable to return the instruction quotation pattern.
 820   token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
 821
 822 : NOP-instruction ( -- parser )
 823   "NOP" simple-instruction ;
 824
 825 : RET-NN-instruction ( -- parser )
 826   "RET-NN" "RET" complex-instruction
 827   "nn" token sp <&
 828   just [ { } clone swap curry  ] <@ ;
 829
 830 : RST-0-instruction ( -- parser )
 831   "RST-0" "RST" complex-instruction
 832   "0" token sp <&
 833   just [ { } clone swap curry  ] <@ ;
 834
 835 : RST-8-instruction ( -- parser )
 836   "RST-8" "RST" complex-instruction
 837   "8" token sp <&
 838   just [ { } clone swap curry  ] <@ ;
 839
 840 : RST-10H-instruction ( -- parser )
 841   "RST-10H" "RST" complex-instruction
 842   "10H" token sp <&
 843   just [ { } clone swap curry  ] <@ ;
 844
 845 : RST-18H-instruction ( -- parser )
 846   "RST-18H" "RST" complex-instruction
 847   "18H" token sp <&
 848   just [ { } clone swap curry  ] <@ ;
 849
 850 : RST-20H-instruction ( -- parser )
 851   "RST-20H" "RST" complex-instruction
 852   "20H" token sp <&
 853   just [ { } clone swap curry  ] <@ ;
 854
 855 : RST-28H-instruction ( -- parser )
 856   "RST-28H" "RST" complex-instruction
 857   "28H" token sp <&
 858   just [ { } clone swap curry  ] <@ ;
 859
 860 : RST-30H-instruction ( -- parser )
 861   "RST-30H" "RST" complex-instruction
 862   "30H" token sp <&
 863   just [ { } clone swap curry  ] <@ ;
 864
 865 : RST-38H-instruction ( -- parser )
 866   "RST-38H" "RST" complex-instruction
 867   "38H" token sp <&
 868   just [ { } clone swap curry  ] <@ ;
 869
 870 : JP-NN-instruction ( -- parser )
 871   "JP-NN" "JP" complex-instruction
 872   "nn" token sp <&
 873   just [ { } clone swap curry  ] <@ ;
 874
 875 : JP-F|FF,NN-instruction ( -- parser )
 876   "JP-F|FF,NN" "JP" complex-instruction
 877   all-flags sp <&>
 878   ",nn" token <&
 879   just [ first2 swap curry ] <@ ;
 880
 881 : JP-(RR)-instruction ( -- parser )
 882   "JP-(RR)" "JP" complex-instruction
 883   16-bit-registers indirect sp <&>
 884   just [ first2 swap curry ] <@ ;
 885
 886 : CALL-NN-instruction ( -- parser )
 887   "CALL-NN" "CALL" complex-instruction
 888   "nn" token sp <&
 889   just [ { } clone swap curry  ] <@ ;
 890
 891 : CALL-F|FF,NN-instruction ( -- parser )
 892   "CALL-F|FF,NN" "CALL" complex-instruction
 893   all-flags sp <&>
 894   ",nn" token <&
 895   just [ first2 swap curry ] <@ ;
 896
 897 : RLCA-instruction ( -- parser )
 898   "RLCA" simple-instruction ;
 899
 900 : RRCA-instruction ( -- parser )
 901   "RRCA" simple-instruction ;
 902
 903 : HALT-instruction ( -- parser )
 904   "HALT" simple-instruction ;
 905
 906 : DI-instruction ( -- parser )
 907   "DI" simple-instruction ;
 908
 909 : EI-instruction ( -- parser )
 910   "EI" simple-instruction ;
 911
 912 : CPL-instruction ( -- parser )
 913   "CPL" simple-instruction ;
 914
 915 : CCF-instruction ( -- parser )
 916   "CCF" simple-instruction ;
 917
 918 : SCF-instruction ( -- parser )
 919   "SCF" simple-instruction ;
 920
 921 : DAA-instruction ( -- parser )
 922   "DAA" simple-instruction ;
 923
 924 : RLA-instruction ( -- parser )
 925   "RLA" simple-instruction ;
 926
 927 : RRA-instruction ( -- parser )
 928   "RRA" simple-instruction ;
 929
 930 : DEC-R-instruction ( -- parser )
 931   "DEC-R" "DEC" complex-instruction  8-bit-registers sp <&>
 932   just [ first2 swap curry ] <@ ;
 933
 934 : DEC-RR-instruction ( -- parser )
 935   "DEC-RR" "DEC" complex-instruction  16-bit-registers sp <&>
 936   just [ first2 swap curry ] <@ ;
 937
 938 : DEC-(RR)-instruction ( -- parser )
 939   "DEC-(RR)" "DEC" complex-instruction
 940   16-bit-registers indirect sp <&>
 941   just [ first2 swap curry ] <@ ;
 942
 943 : POP-RR-instruction ( -- parser )
 944   "POP-RR" "POP" complex-instruction  all-registers sp <&>
 945   just [ first2 swap curry ] <@ ;
 946
 947 : PUSH-RR-instruction ( -- parser )
 948   "PUSH-RR" "PUSH" complex-instruction  all-registers sp <&>
 949   just [ first2 swap curry ] <@ ;
 950
 951 : INC-R-instruction ( -- parser )
 952   "INC-R" "INC" complex-instruction  8-bit-registers sp <&>
 953   just [ first2 swap curry ] <@ ;
 954
 955 : INC-RR-instruction ( -- parser )
 956   "INC-RR" "INC" complex-instruction  16-bit-registers sp <&>
 957   just [ first2 swap curry ] <@ ;
 958
 959 : INC-(RR)-instruction  ( -- parser )
 960   "INC-(RR)" "INC" complex-instruction
 961   all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
 962
 963 : RET-F|FF-instruction ( -- parser )
 964   "RET-F|FF" "RET" complex-instruction  all-flags sp <&>
 965   just [ first2 swap curry ] <@ ;
 966
 967 : AND-N-instruction ( -- parser )
 968   "AND-N" "AND" complex-instruction
 969   "n" token sp <&
 970   just [ { } clone swap curry  ] <@ ;
 971
 972 : AND-R-instruction  ( -- parser )
 973   "AND-R" "AND" complex-instruction
 974   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
 975
 976 : AND-(RR)-instruction  ( -- parser )
 977   "AND-(RR)" "AND" complex-instruction
 978   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
 979
 980 : XOR-N-instruction ( -- parser )
 981   "XOR-N" "XOR" complex-instruction
 982   "n" token sp <&
 983   just [ { } clone swap curry  ] <@ ;
 984
 985 : XOR-R-instruction  ( -- parser )
 986   "XOR-R" "XOR" complex-instruction
 987   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
 988
 989 : XOR-(RR)-instruction  ( -- parser )
 990   "XOR-(RR)" "XOR" complex-instruction
 991   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
 992
 993 : OR-N-instruction ( -- parser )
 994   "OR-N" "OR" complex-instruction
 995   "n" token sp <&
 996   just [ { } clone swap curry  ] <@ ;
 997
 998 : OR-R-instruction  ( -- parser )
 999   "OR-R" "OR" complex-instruction
1000   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1001
1002 : OR-(RR)-instruction  ( -- parser )
1003   "OR-(RR)" "OR" complex-instruction
1004   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1005
1006 : CP-N-instruction ( -- parser )
1007   "CP-N" "CP" complex-instruction
1008   "n" token sp <&
1009   just [ { } clone swap curry  ] <@ ;
1010
1011 : CP-R-instruction  ( -- parser )
1012   "CP-R" "CP" complex-instruction
1013   8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1014
1015 : CP-(RR)-instruction  ( -- parser )
1016   "CP-(RR)" "CP" complex-instruction
1017   16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1018
1019 : ADC-R,N-instruction ( -- parser )
1020   "ADC-R,N" "ADC" complex-instruction
1021   8-bit-registers sp <&>
1022   ",n" token <&
1023   just [ first2 swap curry ] <@ ;
1024
1025 : ADC-R,R-instruction ( -- parser )
1026   "ADC-R,R" "ADC" complex-instruction
1027   8-bit-registers sp <&>
1028   "," token <&
1029   8-bit-registers <&>
1030   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1031
1032 : ADC-R,(RR)-instruction ( -- parser )
1033   "ADC-R,(RR)" "ADC" complex-instruction
1034   8-bit-registers sp <&>
1035   "," token <&
1036   16-bit-registers indirect <&>
1037   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1038
1039 : SBC-R,N-instruction ( -- parser )
1040   "SBC-R,N" "SBC" complex-instruction
1041   8-bit-registers sp <&>
1042   ",n" token <&
1043   just [ first2 swap curry ] <@ ;
1044
1045 : SBC-R,R-instruction ( -- parser )
1046   "SBC-R,R" "SBC" complex-instruction
1047   8-bit-registers sp <&>
1048   "," token <&
1049   8-bit-registers <&>
1050   just [ first2 swap first2 swap >r prepend r> curry  ] <@ ;
1051
1052 : SBC-R,(RR)-instruction ( -- parser )
1053   "SBC-R,(RR)" "SBC" complex-instruction
1054   8-bit-registers sp <&>
1055   "," token <&
1056   16-bit-registers indirect  <&>
1057   just [ first2 swap first2 swap >r prepend r> curry  ] <@ ;
1058
1059 : SUB-R-instruction ( -- parser )
1060   "SUB-R" "SUB" complex-instruction
1061   8-bit-registers sp <&>
1062   just [ first2 swap curry ] <@ ;
1063
1064 : SUB-(RR)-instruction ( -- parser )
1065   "SUB-(RR)" "SUB" complex-instruction
1066   16-bit-registers indirect sp <&>
1067   just [ first2 swap curry ] <@ ;
1068
1069 : SUB-N-instruction ( -- parser )
1070   "SUB-N" "SUB" complex-instruction
1071   "n" token sp <&
1072   just [ { } clone swap curry  ] <@ ;
1073
1074 : ADD-R,N-instruction ( -- parser )
1075   "ADD-R,N" "ADD" complex-instruction
1076   8-bit-registers sp <&>
1077   ",n" token <&
1078   just [ first2 swap curry ] <@ ;
1079
1080 : ADD-R,R-instruction ( -- parser )
1081   "ADD-R,R" "ADD" complex-instruction
1082   8-bit-registers sp <&>
1083   "," token <&
1084   8-bit-registers <&>
1085   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1086
1087 : ADD-RR,RR-instruction ( -- parser )
1088   "ADD-RR,RR" "ADD" complex-instruction
1089   16-bit-registers sp <&>
1090   "," token <&
1091   16-bit-registers <&>
1092   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1093
1094 : ADD-R,(RR)-instruction ( -- parser )
1095   "ADD-R,(RR)" "ADD" complex-instruction
1096   8-bit-registers sp <&>
1097   "," token <&
1098   16-bit-registers indirect <&>
1099   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1100
1101 : LD-RR,NN-instruction
1102   #! LD BC,nn
1103   "LD-RR,NN" "LD" complex-instruction
1104   16-bit-registers sp <&>
1105   ",nn" token <&
1106   just [ first2 swap curry ] <@ ;
1107
1108 : LD-R,N-instruction
1109   #! LD B,n
1110   "LD-R,N" "LD" complex-instruction
1111   8-bit-registers sp <&>
1112   ",n" token <&
1113   just [ first2 swap curry ] <@ ;
1114
1115 : LD-(RR),N-instruction
1116   "LD-(RR),N" "LD" complex-instruction
1117   16-bit-registers indirect sp <&>
1118   ",n" token <&
1119   just [ first2 swap curry ] <@ ;
1120
1121 : LD-(RR),R-instruction
1122   #! LD (BC),A
1123   "LD-(RR),R" "LD" complex-instruction
1124   16-bit-registers indirect sp <&>
1125   "," token <&
1126   8-bit-registers <&>
1127   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1128
1129 : LD-R,R-instruction
1130   "LD-R,R" "LD" complex-instruction
1131   8-bit-registers sp <&>
1132   "," token <&
1133   8-bit-registers <&>
1134   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1135
1136 : LD-RR,RR-instruction
1137   "LD-RR,RR" "LD" complex-instruction
1138   16-bit-registers sp <&>
1139   "," token <&
1140   16-bit-registers <&>
1141   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1142
1143 : LD-R,(RR)-instruction
1144   "LD-R,(RR)" "LD" complex-instruction
1145   8-bit-registers sp <&>
1146   "," token <&
1147   16-bit-registers indirect <&>
1148   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1149
1150 : LD-(NN),RR-instruction
1151   "LD-(NN),RR" "LD" complex-instruction
1152   "nn" token indirect sp <&
1153   "," token <&
1154   16-bit-registers <&>
1155   just [ first2 swap curry ] <@ ;
1156
1157 : LD-(NN),R-instruction
1158   "LD-(NN),R" "LD" complex-instruction
1159   "nn" token indirect sp <&
1160   "," token <&
1161   8-bit-registers <&>
1162   just [ first2 swap curry ] <@ ;
1163
1164 : LD-RR,(NN)-instruction
1165   "LD-RR,(NN)" "LD" complex-instruction
1166   16-bit-registers sp <&>
1167   "," token <&
1168   "nn" token indirect <&
1169   just [ first2 swap curry ] <@ ;
1170
1171 : LD-R,(NN)-instruction
1172   "LD-R,(NN)" "LD" complex-instruction
1173   8-bit-registers sp <&>
1174   "," token <&
1175   "nn" token indirect <&
1176   just [ first2 swap curry ] <@ ;
1177
1178 : OUT-(N),R-instruction
1179   "OUT-(N),R" "OUT" complex-instruction
1180   "n" token indirect sp <&
1181   "," token <&
1182   8-bit-registers <&>
1183   just [ first2 swap curry ] <@ ;
1184
1185 : IN-R,(N)-instruction
1186   "IN-R,(N)" "IN" complex-instruction
1187   8-bit-registers sp <&>
1188   "," token <&
1189   "n" token indirect <&
1190   just [ first2 swap curry ] <@ ;
1191
1192 : EX-(RR),RR-instruction
1193   "EX-(RR),RR" "EX" complex-instruction
1194   16-bit-registers indirect sp <&>
1195   "," token <&
1196   16-bit-registers <&>
1197   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1198
1199 : EX-RR,RR-instruction
1200   "EX-RR,RR" "EX" complex-instruction
1201   16-bit-registers sp <&>
1202   "," token <&
1203   16-bit-registers <&>
1204   just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1205
1206 : 8080-generator-parser
1207   NOP-instruction
1208   RST-0-instruction <|>
1209   RST-8-instruction <|>
1210   RST-10H-instruction <|>
1211   RST-18H-instruction <|>
1212   RST-20H-instruction <|>
1213   RST-28H-instruction <|>
1214   RST-30H-instruction <|>
1215   RST-38H-instruction <|>
1216   JP-F|FF,NN-instruction <|>
1217   JP-NN-instruction <|>
1218   JP-(RR)-instruction <|>
1219   CALL-F|FF,NN-instruction <|>
1220   CALL-NN-instruction <|>
1221   CPL-instruction <|>
1222   CCF-instruction <|>
1223   SCF-instruction <|>
1224   DAA-instruction <|>
1225   RLA-instruction <|>
1226   RRA-instruction <|>
1227   RLCA-instruction <|>
1228   RRCA-instruction <|>
1229   HALT-instruction <|>
1230   DI-instruction <|>
1231   EI-instruction <|>
1232   AND-N-instruction <|>
1233   AND-R-instruction <|>
1234   AND-(RR)-instruction <|>
1235   XOR-N-instruction <|>
1236   XOR-R-instruction <|>
1237   XOR-(RR)-instruction <|>
1238   OR-N-instruction <|>
1239   OR-R-instruction <|>
1240   OR-(RR)-instruction <|>
1241   CP-N-instruction <|>
1242   CP-R-instruction <|>
1243   CP-(RR)-instruction <|>
1244   DEC-RR-instruction <|>
1245   DEC-R-instruction <|>
1246   DEC-(RR)-instruction <|>
1247   POP-RR-instruction <|>
1248   PUSH-RR-instruction <|>
1249   INC-RR-instruction <|>
1250   INC-R-instruction <|>
1251   INC-(RR)-instruction <|>
1252   LD-RR,NN-instruction <|>
1253   LD-R,N-instruction <|>
1254   LD-R,R-instruction <|>
1255   LD-RR,RR-instruction <|>
1256   LD-(RR),N-instruction <|>
1257   LD-(RR),R-instruction <|>
1258   LD-R,(RR)-instruction <|>
1259   LD-(NN),RR-instruction <|>
1260   LD-(NN),R-instruction <|>
1261   LD-RR,(NN)-instruction <|>
1262   LD-R,(NN)-instruction <|>
1263   ADC-R,N-instruction <|>
1264   ADC-R,R-instruction <|>
1265   ADC-R,(RR)-instruction <|>
1266   ADD-R,N-instruction <|>
1267   ADD-R,R-instruction <|>
1268   ADD-RR,RR-instruction <|>
1269   ADD-R,(RR)-instruction <|>
1270   SBC-R,N-instruction <|>
1271   SBC-R,R-instruction <|>
1272   SBC-R,(RR)-instruction <|>
1273   SUB-R-instruction <|>
1274   SUB-(RR)-instruction <|>
1275   SUB-N-instruction <|>
1276   RET-F|FF-instruction <|>
1277   RET-NN-instruction <|>
1278   OUT-(N),R-instruction <|>
1279   IN-R,(N)-instruction <|>
1280   EX-(RR),RR-instruction <|>
1281   EX-RR,RR-instruction <|>
1282   just ;
1283
1284 : instruction-quotations ( string -- emulate-quot )
1285   #! Given an instruction string, return the emulation quotation for
1286   #! it. This will later be expanded to produce the disassembly and
1287   #! assembly quotations.
1288   8080-generator-parser some parse call ;
1289
1290 SYMBOL: last-instruction
1291 SYMBOL: last-opcode
1292
1293 : parse-instructions ( list -- emulate-quot )
1294   #! Process the list of strings, which should make
1295   #! up an 8080 instruction, and output a quotation
1296   #! that would implement that instruction.
1297   dup " " join instruction-quotations
1298   >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
1299   r> define ;
1300
1301 : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
1302
1303 : cycles ( -- )
1304   #! Set the number of cycles for the last instruction that was defined.
1305   scan string>number last-opcode global at instruction-cycles set-nth ; parsing
1306
1307 : opcode ( -- )
1308   #! Set the opcode number for the last instruction that was defined.
1309   last-instruction global at 1quotation scan 16 base>
1310   dup last-opcode global set-at set-instruction ; parsing
1311