extra/cpu/8080/emulator/emulator.factor

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