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