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