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