! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators fry io io.encodings.binary io.files io.pathnames kernel lexer make math math.parser namespaces parser peg peg.ebnf peg.parsers quotations sequences sequences.deep words ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; GENERIC: reset ( cpu -- ) GENERIC: update-video ( value addr cpu -- ) GENERIC: read-port ( port cpu -- byte ) GENERIC: write-port ( value port cpu -- ) M: cpu update-video 3drop ; M: cpu read-port ! Read a byte from the hardware port. 'port' should ! be an 8-bit value. 2drop 0 ; M: cpu write-port ! Write a byte to the hardware port, where 'port' is ! an 8-bit value. 3drop ; CONSTANT: carry-flag 0x01 CONSTANT: parity-flag 0x04 CONSTANT: half-carry-flag 0x10 CONSTANT: interrupt-flag 0x20 CONSTANT: zero-flag 0x40 CONSTANT: sign-flag 0x80 : >word< ( word -- byte byte ) ! Explode a word into its two 8 bit values. dup 0xFF bitand swap -8 shift 0xFF bitand swap ; : af>> ( cpu -- word ) ! Return the 16-bit pseudo register AF. [ a>> 8 shift ] keep f>> bitor ; : af<< ( value cpu -- ) ! Set the value of the 16-bit pseudo register AF [ >word< ] dip swap >>f swap >>a drop ; : bc>> ( cpu -- word ) ! Return the 16-bit pseudo register BC. [ b>> 8 shift ] keep c>> bitor ; : bc<< ( value cpu -- ) ! Set the value of the 16-bit pseudo register BC [ >word< ] dip swap >>c swap >>b drop ; : de>> ( cpu -- word ) ! Return the 16-bit pseudo register DE. [ d>> 8 shift ] keep e>> bitor ; : de<< ( value cpu -- ) ! Set the value of the 16-bit pseudo register DE [ >word< ] dip swap >>e swap >>d drop ; : hl>> ( cpu -- word ) ! Return the 16-bit pseudo register HL. [ h>> 8 shift ] keep l>> bitor ; : hl<< ( value cpu -- ) ! Set the value of the 16-bit pseudo register HL [ >word< ] dip swap >>l swap >>h drop ; : flag-set? ( flag cpu -- bool ) f>> bitand 0 = not ; : flag-clear? ( flag cpu -- bool ) f>> bitand 0 = ; : flag-nz? ( cpu -- bool ) ! Test flag status f>> zero-flag bitand 0 = ; : flag-z? ( cpu -- bool ) ! Test flag status f>> zero-flag bitand 0 = not ; : flag-nc? ( cpu -- bool ) ! Test flag status f>> carry-flag bitand 0 = ; : flag-c? ( cpu -- bool ) ! Test flag status f>> carry-flag bitand 0 = not ; : flag-po? ( cpu -- bool ) ! Test flag status f>> parity-flag bitand 0 = ; : flag-pe? ( cpu -- bool ) ! Test flag status f>> parity-flag bitand 0 = not ; : flag-p? ( cpu -- bool ) ! Test flag status f>> sign-flag bitand 0 = ; : flag-m? ( cpu -- bool ) ! Test flag status f>> sign-flag bitand 0 = not ; : read-byte ( addr cpu -- byte ) ! Read one byte from memory at the specified address. ! The address is 16-bit, but if a value greater than ! 0xFFFF is provided then return a default value. over 0xFFFF <= [ ram>> nth ] [ 2drop 0xFF ] if ; : read-word ( addr cpu -- word ) ! Read a 16-bit word from memory at the specified address. ! The address is 16-bit, but if a value greater than ! 0xFFFF is provided then return a default value. [ read-byte ] 2keep [ 1 + ] dip read-byte 8 shift bitor ; : next-byte ( cpu -- byte ) ! Return the value of the byte at PC, and increment PC. { [ pc>> ] [ read-byte ] [ pc>> 1 + ] [ pc<< ] } cleave ; : next-word ( cpu -- word ) ! Return the value of the word at PC, and increment PC. [ pc>> ] keep [ read-word ] keep [ pc>> 2 + ] keep pc<< ; : write-byte ( value addr cpu -- ) ! Write a byte to the specified memory address. over dup 0x2000 < swap 0xFFFF > or [ 3drop ] [ 3dup ram>> set-nth update-video ] if ; : write-word ( value addr cpu -- ) ! Write a 16-bit word to the specified memory address. [ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ; : cpu-a-bitand ( quot cpu -- ) ! A &= quot call [ a>> swap call bitand ] keep a<< ; inline : cpu-a-bitor ( quot cpu -- ) ! A |= quot call [ a>> swap call bitor ] keep a<< ; inline : cpu-a-bitxor ( quot cpu -- ) ! A ^= quot call [ a>> swap call bitxor ] keep a<< ; inline : cpu-a-bitxor= ( value cpu -- ) ! cpu-a ^= value [ a>> bitxor ] keep a<< ; : cpu-f-bitand ( quot cpu -- ) ! F &= quot call [ f>> swap call bitand ] keep f<< ; inline : cpu-f-bitor ( quot cpu -- ) ! F |= quot call [ f>> swap call bitor ] keep f<< ; inline : cpu-f-bitxor ( quot cpu -- ) ! F |= quot call [ f>> swap call bitxor ] keep f<< ; inline : cpu-f-bitor= ( value cpu -- ) ! cpu-f |= value [ f>> bitor ] keep f<< ; : cpu-f-bitand= ( value cpu -- ) ! cpu-f &= value [ f>> bitand ] keep f<< ; : cpu-f-bitxor= ( value cpu -- ) ! cpu-f ^= value [ f>> bitxor ] keep f<< ; : set-flag ( cpu flag -- ) swap cpu-f-bitor= ; : clear-flag ( cpu flag -- ) bitnot 0xFF bitand swap cpu-f-bitand= ; : update-zero-flag ( result cpu -- ) ! If the result of an instruction has the value 0, this ! flag is set, otherwise it is reset. swap 0xFF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ; : update-sign-flag ( result cpu -- ) ! If the most significant bit of the result ! has the value 1 then the flag is set, otherwise ! it is reset. swap 0x80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ; : update-parity-flag ( result cpu -- ) ! If the modulo 2 sum of the bits of the result ! is 0, (ie. if the result has even parity) this flag ! is set, otherwise it is reset. swap 0xFF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ; : update-carry-flag ( result cpu -- ) ! If the instruction resulted in a carry (from addition) ! or a borrow (from subtraction or a comparison) out of the ! higher order bit, this flag is set, otherwise it is reset. swap dup 0x100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ; : update-half-carry-flag ( original change-by result cpu -- ) ! If the instruction caused a carry out of bit 3 and into bit 4 of the ! resulting value, the half carry flag is set, otherwise it is reset. ! The 'original' is the original value of the register being changed. ! 'change-by' is the amount it is being added or decremented by. ! 'result' is the result of that change. [ bitxor bitxor 0x10 bitand 0 = not ] dip swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ; : update-flags ( result cpu -- ) { [ update-carry-flag ] [ update-parity-flag ] [ update-sign-flag ] [ update-zero-flag ] } 2cleave ; : update-flags-no-carry ( result cpu -- ) [ update-parity-flag ] [ update-sign-flag ] [ update-zero-flag ] 2tri ; : add-byte ( lhs rhs cpu -- result ) ! Add rhs to lhs [ 2dup + ] dip [ update-flags ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : add-carry ( change-by result cpu -- change-by result ) ! Add the effect of the carry flag to the result flag-c? [ 1 + [ 1 + ] dip ] when ; : add-byte-with-carry ( lhs rhs cpu -- result ) ! Add rhs to lhs plus carry. [ 2dup + ] dip [ add-carry ] keep [ update-flags ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : sub-carry ( change-by result cpu -- change-by result ) ! Subtract the effect of the carry flag from the result flag-c? [ 1 - [ 1 - ] dip ] when ; : sub-byte ( lhs rhs cpu -- result ) ! Subtract rhs from lhs [ 2dup - ] dip [ update-flags ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : sub-byte-with-carry ( lhs rhs cpu -- result ) ! Subtract rhs from lhs and take carry into account [ 2dup - ] dip [ sub-carry ] keep [ update-flags ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : inc-byte ( byte cpu -- result ) ! Increment byte by one. Note that carry flag is not affected ! by this operation. [ 1 2dup + ] dip [ update-flags-no-carry ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : dec-byte ( byte cpu -- result ) ! Decrement byte by one. Note that carry flag is not affected ! by this operation. [ 1 2dup - ] dip [ update-flags-no-carry ] 2keep [ update-half-carry-flag ] 2keep drop 0xFF bitand ; : inc-word ( w cpu -- w ) ! Increment word by one. Note that no flags are modified. drop 1 + 0xFFFF bitand ; : dec-word ( w cpu -- w ) ! Decrement word by one. Note that no flags are modified. drop 1 - 0xFFFF bitand ; : add-word ( lhs rhs cpu -- result ) ! Add rhs to lhs. Note that only the carry flag is modified ! and only if there is a carry out of the double precision add. [ + ] dip over 0xFFFF > [ carry-flag set-flag ] [ drop ] if 0xFFFF bitand ; : bit3or ( lhs rhs -- 0|1 ) ! bitor bit 3 of the two numbers on the stack [ 0b00001000 bitand -3 shift ] bi@ bitor ; : and-byte ( lhs rhs cpu -- result ) ! Logically and rhs to lhs. The carry flag is cleared and ! the half carry is set to the ORing of bits 3 of the operands. [ drop bit3or ] 3keep ! bit3or lhs rhs cpu [ bitand ] dip [ update-flags ] 2keep [ carry-flag clear-flag ] keep rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if 0xFF bitand ; : xor-byte ( lhs rhs cpu -- result ) ! Logically xor rhs to lhs. The carry and half-carry flags are cleared. [ bitxor ] dip [ update-flags ] 2keep half-carry-flag carry-flag bitor clear-flag 0xFF bitand ; : or-byte ( lhs rhs cpu -- result ) ! Logically or rhs to lhs. The carry and half-carry flags are cleared. [ bitor ] dip [ update-flags ] 2keep half-carry-flag carry-flag bitor clear-flag 0xFF bitand ; : decrement-sp ( n cpu -- ) ! Decrement the stackpointer by n. [ sp>> swap - ] keep sp<< ; : save-pc ( cpu -- ) ! Save the value of the PC on the stack. [ pc>> ] [ sp>> ] [ write-word ] tri ; : push-pc ( cpu -- ) ! Push the value of the PC on the stack. [ 2 swap decrement-sp ] [ save-pc ] bi ; : pop-pc ( cpu -- pc ) ! Pop the value of the PC off the stack. [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ; : push-sp ( value cpu -- ) [ 2 swap decrement-sp ] [ sp>> ] [ write-word ] tri ; : pop-sp ( cpu -- value ) [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ; : call-sub ( addr cpu -- ) ! Call the address as a subroutine. dup push-pc [ 0xFFFF bitand ] dip pc<< ; : ret-from-sub ( cpu -- ) [ pop-pc ] keep pc<< ; : interrupt ( number cpu -- ) ! Perform a hardware interrupt ! "***Interrupt: " write over >hex print dup f>> interrupt-flag bitand 0 = not [ dup push-pc pc<< ] [ 2drop ] if ; : inc-cycles ( n cpu -- ) ! Increment the number of cpu cycles [ cycles>> + ] keep cycles<< ; : instruction-cycles ( -- vector ) ! Return a 256 element vector containing the cycles for ! each opcode in the 8080 instruction set. \ instruction-cycles get-global [ 256 f \ instruction-cycles set-global ] unless \ instruction-cycles get-global ; : not-implemented ( cpu -- ) drop ; : instructions ( -- vector ) ! Return a 256 element vector containing the emulation words for ! each opcode in the 8080 instruction set. \ instructions get-global [ 256 [ not-implemented ] \ instructions set-global ] unless \ instructions get-global ; : set-instruction ( quot n -- ) instructions set-nth ; M: cpu reset ! Reset the CPU to its poweron state 0 >>b 0 >>c 0 >>d 0 >>e 0 >>h 0 >>l 0 >>a 0 >>f 0 >>pc 0xF000 >>sp 0xFFFF 0 >>ram f >>halted? 0x10 >>last-interrupt 0 >>cycles drop ; : ( -- cpu ) cpu new dup reset ; : (load-rom) ( n ram -- ) read1 [ ! n ram ch -rot [ set-nth ] 2keep [ 1 + ] dip (load-rom) ] [ 2drop ] if* ; ! Reads the ROM from stdin and stores it in ROM from ! offset n. : load-rom ( filename cpu -- ) ! Load the contents of the file into ROM. ! (address 0x0000-0x1FFF). ram>> swap binary [ 0 swap (load-rom) ] with-file-reader ; SYMBOL: rom-root : rom-dir ( -- string ) rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ; : load-rom* ( seq cpu -- ) ! 'seq' is an array of arrays. Each array contains ! an address and filename of a ROM file. The ROM ! file will be loaded at the specified address. This ! file path shoul dbe relative to the '/roms' resource path. rom-dir [ ram>> [ swap first2 rom-dir prepend-path binary [ swap (load-rom) ] with-file-reader ] curry each ] [ ! ! the ROM files. "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw ] if ; : read-instruction ( cpu -- word ) ! Read the next instruction from the cpu's program ! counter, and increment the program counter. [ pc>> ] keep ! pc cpu [ over 1 + swap pc<< ] keep read-byte ; ERROR: undefined-8080-opcode n ; : get-cycles ( n -- opcode ) ! Returns the cycles for the given instruction value. ! If the opcode is not defined throw an error. dup instruction-cycles nth [ nip ] [ undefined-8080-opcode ] if* ; : process-interrupts ( cpu -- ) ! Process any hardware interrupts [ cycles>> ] keep over 16667 < [ 2drop ] [ [ [ 16667 - ] dip cycles<< ] keep dup last-interrupt>> 0x10 = [ 0x08 >>last-interrupt 0x08 swap interrupt ] [ 0x10 >>last-interrupt 0x10 swap interrupt ] if ] if ; : peek-instruction ( cpu -- word ) ! Return the next instruction from the cpu's program ! counter, but don't increment the counter. [ pc>> ] keep read-byte instructions nth first ; : cpu. ( cpu -- ) { [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ] [ " B: " write b>> >hex 2 CHAR: \s pad-head write ] [ " C: " write c>> >hex 2 CHAR: \s pad-head write ] [ " D: " write d>> >hex 2 CHAR: \s pad-head write ] [ " E: " write e>> >hex 2 CHAR: \s pad-head write ] [ " F: " write f>> >hex 2 CHAR: \s pad-head write ] [ " H: " write h>> >hex 2 CHAR: \s pad-head write ] [ " L: " write l>> >hex 2 CHAR: \s pad-head write ] [ " A: " write a>> >hex 2 CHAR: \s pad-head write ] [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ] [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] [ bl peek-instruction name>> write bl ] [ nl drop ] } cleave ; : cpu*. ( cpu -- ) { [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ] [ " B: " write b>> >hex 2 CHAR: \s pad-head write ] [ " C: " write c>> >hex 2 CHAR: \s pad-head write ] [ " D: " write d>> >hex 2 CHAR: \s pad-head write ] [ " E: " write e>> >hex 2 CHAR: \s pad-head write ] [ " F: " write f>> >hex 2 CHAR: \s pad-head write ] [ " H: " write h>> >hex 2 CHAR: \s pad-head write ] [ " L: " write l>> >hex 2 CHAR: \s pad-head write ] [ " A: " write a>> >hex 2 CHAR: \s pad-head write ] [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ] [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] [ nl drop ] } cleave ; : register-lookup ( string -- vector ) ! Given a string containing a register name, return a vector ! where the 1st item is the getter and the 2nd is the setter ! for that register. H{ { "A" { a>> a<< } } { "B" { b>> b<< } } { "C" { c>> c<< } } { "D" { d>> d<< } } { "E" { e>> e<< } } { "H" { h>> h<< } } { "L" { l>> l<< } } { "AF" { af>> af<< } } { "BC" { bc>> bc<< } } { "DE" { de>> de<< } } { "HL" { hl>> hl<< } } { "SP" { sp>> sp<< } } } at ; : flag-lookup ( string -- vector ) ! Given a string containing a flag name, return a vector ! where the 1st item is a word that tests that flag. H{ { "NZ" { flag-nz? } } { "NC" { flag-nc? } } { "PO" { flag-po? } } { "PE" { flag-pe? } } { "Z" { flag-z? } } { "C" { flag-c? } } { "P" { flag-p? } } { "M" { flag-m? } } } at ; SYMBOLS: $1 $2 $3 $4 ; : replace-patterns ( vector tree -- tree ) [ { { $1 [ first ] } { $2 [ second ] } { $3 [ third ] } { $4 [ fourth ] } [ nip ] } case ] with deep-map ; : (emulate-RST) ( n cpu -- ) ! RST nn [ sp>> 2 - dup ] keep ! sp sp cpu [ sp<< ] keep ! sp cpu [ pc>> ] keep ! sp pc cpu swapd [ write-word ] keep ! cpu [ 8 * ] dip pc<< ; : (emulate-CALL) ( cpu -- ) ! 205 - CALL nn [ next-word 0xFFFF bitand ] keep ! addr cpu [ sp>> 2 - dup ] keep ! addr sp sp cpu [ sp<< ] keep ! addr sp cpu [ pc>> ] keep ! addr sp pc cpu swapd [ write-word ] keep ! addr cpu pc<< ; : (emulate-RLCA) ( cpu -- ) ! The content of the accumulator is rotated left ! one position. The low order bit and the carry flag ! are both set to the value shifd out of the high ! order bit position. Only the carry flag is affected. [ a>> -7 shift ] keep over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ a>> 1 shift 0xFF bitand ] keep [ bitor ] dip a<< ; : (emulate-RRCA) ( cpu -- ) ! The content of the accumulator is rotated right ! one position. The high order bit and the carry flag ! are both set to the value shifd out of the low ! order bit position. Only the carry flag is affected. [ a>> 1 bitand 7 shift ] keep over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ a>> 254 bitand -1 shift ] keep [ bitor ] dip a<< ; : (emulate-RLA) ( cpu -- ) ! The content of the accumulator is rotated left ! one position through the carry flag. The low ! order bit is set equal to the carry flag and ! the carry flag is set to the value shifd out ! of the high order bit. Only the carry flag is ! affected. [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep [ a>> 127 bitand 7 shift ] keep dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ bitor ] dip a<< ; : (emulate-RRA) ( cpu -- ) ! The content of the accumulator is rotated right ! one position through the carry flag. The high order ! bit is set to the carry flag and the carry flag is ! set to the value shifd out of the low order bit. ! Only the carry flag is affected. [ carry-flag swap flag-set? [ 0b10000000 ] [ 0 ] if ] keep [ a>> 254 bitand -1 shift ] keep dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ bitor ] dip a<< ; : (emulate-CPL) ( cpu -- ) ! The contents of the accumulator are complemented ! (zero bits become one, one bits becomes zero). ! No flags are affected. 0xFF swap cpu-a-bitxor= ; : (emulate-DAA) ( cpu -- ) ! The eight bit number in the accumulator is ! adjusted to form two four-bit binary-coded-decimal ! digits. [ dup half-carry-flag swap flag-set? swap a>> 0b1111 bitand 9 > or [ 6 ] [ 0 ] if ] keep [ a>> + ] keep [ update-flags ] 2keep [ swap 0xFF bitand swap a<< ] keep [ dup carry-flag swap flag-set? swap a>> -4 shift 0b1111 bitand 9 > or [ 96 ] [ 0 ] if ] keep [ a>> + ] keep [ update-flags ] 2keep swap 0xFF bitand swap a<< ; : patterns ( -- hashtable ) ! table of code quotation patterns for each type of instruction. H{ { "NOP" [ drop ] } { "RET-NN" [ ret-from-sub ] } { "RST-0" [ 0 swap (emulate-RST) ] } { "RST-8" [ 8 swap (emulate-RST) ] } { "RST-10H" [ 0x10 swap (emulate-RST) ] } { "RST-18H" [ 0x18 swap (emulate-RST) ] } { "RST-20H" [ 0x20 swap (emulate-RST) ] } { "RST-28H" [ 0x28 swap (emulate-RST) ] } { "RST-30H" [ 0x30 swap (emulate-RST) ] } { "RST-38H" [ 0x38 swap (emulate-RST) ] } { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] } { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] } { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] } { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep a<< ] } { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep a<< ] } { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep a<< ] } { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep a<< ] } { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep a<< ] } { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep a<< ] } { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep a<< ] } { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep a<< ] } { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep a<< ] } { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] } { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] } { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] } { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] } { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] } { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] } { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] } { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep a<< ] } { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep a<< ] } { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep a<< ] } { "CPL" [ (emulate-CPL) ] } { "DAA" [ (emulate-DAA) ] } { "RLA" [ (emulate-RLA) ] } { "RRA" [ (emulate-RRA) ] } { "CCF" [ carry-flag swap cpu-f-bitxor= ] } { "SCF" [ carry-flag swap cpu-f-bitor= ] } { "RLCA" [ (emulate-RLCA) ] } { "RRCA" [ (emulate-RRCA) ] } { "HALT" [ drop ] } { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } { "POP-RR" [ [ pop-sp ] keep $2 ] } { "PUSH-RR" [ [ $1 ] keep push-sp ] } { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] } { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] } { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] } { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] } { "JP-NN" [ [ pc>> ] keep [ read-word ] keep pc<< ] } { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ pc<< ] keep [ cycles>> ] keep swap 5 + swap cycles<< ] [ [ pc>> 2 + ] keep pc<< ] if ] } { "JP-(RR)" [ [ $1 ] keep pc<< ] } { "CALL-NN" [ (emulate-CALL) ] } { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep pc<< ] if ] } { "LD-RR,NN" [ [ next-word ] keep $2 ] } { "LD-RR,RR" [ [ $3 ] keep $2 ] } { "LD-R,N" [ [ next-byte ] keep $2 ] } { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } { "LD-R,R" [ [ $3 ] keep $2 ] } { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep a<< ] } { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] } { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] } } ; : 8-bit-registers ( -- parser ) ! A parser for 8-bit registers. On a successfull parse the ! parse tree contains a vector. The first item in the vector ! is the getter word for that register with stack effect ! ( cpu -- value ). The second item is the setter word with ! stack effect ( value cpu -- ). [[ register-lookup ]] EBNF> ; : all-flags ( -- parser ) ! A parser for 16-bit flags. [[ flag-lookup ]] EBNF> ; : 16-bit-registers ( -- parser ) ! A parser for 16-bit registers. On a successfull parse the ! parse tree contains a vector. The first item in the vector ! is the getter word for that register with stack effect ! ( cpu -- value ). The second item is the setter word with ! stack effect ( value cpu -- ). [[ register-lookup ]] EBNF> ; : all-registers ( -- parser ) ! Return a parser that can parse the format ! for 8 bit or 16 bit registers. [ 16-bit-registers , 8-bit-registers , ] choice* ; : indirect ( parser -- parser ) ! Given a parser, return a parser which parses the original ! wrapped in brackets, representing an indirect reference. ! eg. BC -> (BC). The value of the original parser is left in ! the parse tree. "(" ")" surrounded-by ; : generate-instruction ( vector string -- quot ) ! Generate the quotation for an instruction, given the instruction in ! the 'string' and a vector containing the arguments for that instruction. patterns at replace-patterns ; : simple-instruction ( token -- parser ) ! Return a parser for then instruction identified by the token. ! The parser return parses the token only and expects no additional ! arguments to the instruction. token [ '[ { } _ generate-instruction ] ] action ; : complex-instruction ( type token -- parser ) ! Return a parser for an instruction identified by the token. ! The instruction is expected to take additional arguments by ! being combined with other parsers. Then 'type' is used for a lookup ! in a pattern hashtable to return the instruction quotation pattern. token swap [ nip '[ _ generate-instruction ] ] curry action ; : no-params ( ast -- ast ) first { } swap curry ; : one-param ( ast -- ast ) first2 swap curry ; : two-params ( ast -- ast ) first3 append swap curry ; : NOP-instruction ( -- parser ) "NOP" simple-instruction ; : RET-NN-instruction ( -- parser ) [ "RET-NN" "RET" complex-instruction , "nn" token sp hide , ] seq* [ no-params ] action ; : RST-0-instruction ( -- parser ) [ "RST-0" "RST" complex-instruction , "0" token sp hide , ] seq* [ no-params ] action ; : RST-8-instruction ( -- parser ) [ "RST-8" "RST" complex-instruction , "8" token sp hide , ] seq* [ no-params ] action ; : RST-10H-instruction ( -- parser ) [ "RST-10H" "RST" complex-instruction , "10H" token sp hide , ] seq* [ no-params ] action ; : RST-18H-instruction ( -- parser ) [ "RST-18H" "RST" complex-instruction , "18H" token sp hide , ] seq* [ no-params ] action ; : RST-20H-instruction ( -- parser ) [ "RST-20H" "RST" complex-instruction , "20H" token sp hide , ] seq* [ no-params ] action ; : RST-28H-instruction ( -- parser ) [ "RST-28H" "RST" complex-instruction , "28H" token sp hide , ] seq* [ no-params ] action ; : RST-30H-instruction ( -- parser ) [ "RST-30H" "RST" complex-instruction , "30H" token sp hide , ] seq* [ no-params ] action ; : RST-38H-instruction ( -- parser ) [ "RST-38H" "RST" complex-instruction , "38H" token sp hide , ] seq* [ no-params ] action ; : JP-NN-instruction ( -- parser ) [ "JP-NN" "JP" complex-instruction , "nn" token sp hide , ] seq* [ no-params ] action ; : JP-F|FF,NN-instruction ( -- parser ) [ "JP-F|FF,NN" "JP" complex-instruction , all-flags sp , ",nn" token hide , ] seq* [ one-param ] action ; : JP-(RR)-instruction ( -- parser ) [ "JP-(RR)" "JP" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : CALL-NN-instruction ( -- parser ) [ "CALL-NN" "CALL" complex-instruction , "nn" token sp hide , ] seq* [ no-params ] action ; : CALL-F|FF,NN-instruction ( -- parser ) [ "CALL-F|FF,NN" "CALL" complex-instruction , all-flags sp , ",nn" token hide , ] seq* [ one-param ] action ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; : RRCA-instruction ( -- parser ) "RRCA" simple-instruction ; : HALT-instruction ( -- parser ) "HALT" simple-instruction ; : DI-instruction ( -- parser ) "DI" simple-instruction ; : EI-instruction ( -- parser ) "EI" simple-instruction ; : CPL-instruction ( -- parser ) "CPL" simple-instruction ; : CCF-instruction ( -- parser ) "CCF" simple-instruction ; : SCF-instruction ( -- parser ) "SCF" simple-instruction ; : DAA-instruction ( -- parser ) "DAA" simple-instruction ; : RLA-instruction ( -- parser ) "RLA" simple-instruction ; : RRA-instruction ( -- parser ) "RRA" simple-instruction ; : DEC-R-instruction ( -- parser ) [ "DEC-R" "DEC" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : DEC-RR-instruction ( -- parser ) [ "DEC-RR" "DEC" complex-instruction , 16-bit-registers sp , ] seq* [ one-param ] action ; : DEC-(RR)-instruction ( -- parser ) [ "DEC-(RR)" "DEC" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : POP-RR-instruction ( -- parser ) [ "POP-RR" "POP" complex-instruction , all-registers sp , ] seq* [ one-param ] action ; : PUSH-RR-instruction ( -- parser ) [ "PUSH-RR" "PUSH" complex-instruction , all-registers sp , ] seq* [ one-param ] action ; : INC-R-instruction ( -- parser ) [ "INC-R" "INC" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : INC-RR-instruction ( -- parser ) [ "INC-RR" "INC" complex-instruction , 16-bit-registers sp , ] seq* [ one-param ] action ; : INC-(RR)-instruction ( -- parser ) [ "INC-(RR)" "INC" complex-instruction , all-registers indirect sp , ] seq* [ one-param ] action ; : RET-F|FF-instruction ( -- parser ) [ "RET-F|FF" "RET" complex-instruction , all-flags sp , ] seq* [ one-param ] action ; : AND-N-instruction ( -- parser ) [ "AND-N" "AND" complex-instruction , "n" token sp hide , ] seq* [ no-params ] action ; : AND-R-instruction ( -- parser ) [ "AND-R" "AND" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : AND-(RR)-instruction ( -- parser ) [ "AND-(RR)" "AND" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : XOR-N-instruction ( -- parser ) [ "XOR-N" "XOR" complex-instruction , "n" token sp hide , ] seq* [ no-params ] action ; : XOR-R-instruction ( -- parser ) [ "XOR-R" "XOR" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : XOR-(RR)-instruction ( -- parser ) [ "XOR-(RR)" "XOR" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : OR-N-instruction ( -- parser ) [ "OR-N" "OR" complex-instruction , "n" token sp hide , ] seq* [ no-params ] action ; : OR-R-instruction ( -- parser ) [ "OR-R" "OR" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : OR-(RR)-instruction ( -- parser ) [ "OR-(RR)" "OR" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : CP-N-instruction ( -- parser ) [ "CP-N" "CP" complex-instruction , "n" token sp hide , ] seq* [ no-params ] action ; : CP-R-instruction ( -- parser ) [ "CP-R" "CP" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : CP-(RR)-instruction ( -- parser ) [ "CP-(RR)" "CP" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : ADC-R,N-instruction ( -- parser ) [ "ADC-R,N" "ADC" complex-instruction , 8-bit-registers sp , ",n" token hide , ] seq* [ one-param ] action ; : ADC-R,R-instruction ( -- parser ) [ "ADC-R,R" "ADC" complex-instruction , 8-bit-registers sp , "," token hide , 8-bit-registers , ] seq* [ two-params ] action ; : ADC-R,(RR)-instruction ( -- parser ) [ "ADC-R,(RR)" "ADC" complex-instruction , 8-bit-registers sp , "," token hide , 16-bit-registers indirect , ] seq* [ two-params ] action ; : SBC-R,N-instruction ( -- parser ) [ "SBC-R,N" "SBC" complex-instruction , 8-bit-registers sp , ",n" token hide , ] seq* [ one-param ] action ; : SBC-R,R-instruction ( -- parser ) [ "SBC-R,R" "SBC" complex-instruction , 8-bit-registers sp , "," token hide , 8-bit-registers , ] seq* [ two-params ] action ; : SBC-R,(RR)-instruction ( -- parser ) [ "SBC-R,(RR)" "SBC" complex-instruction , 8-bit-registers sp , "," token hide , 16-bit-registers indirect , ] seq* [ two-params ] action ; : SUB-R-instruction ( -- parser ) [ "SUB-R" "SUB" complex-instruction , 8-bit-registers sp , ] seq* [ one-param ] action ; : SUB-(RR)-instruction ( -- parser ) [ "SUB-(RR)" "SUB" complex-instruction , 16-bit-registers indirect sp , ] seq* [ one-param ] action ; : SUB-N-instruction ( -- parser ) [ "SUB-N" "SUB" complex-instruction , "n" token sp hide , ] seq* [ no-params ] action ; : ADD-R,N-instruction ( -- parser ) [ "ADD-R,N" "ADD" complex-instruction , 8-bit-registers sp , ",n" token hide , ] seq* [ one-param ] action ; : ADD-R,R-instruction ( -- parser ) [ "ADD-R,R" "ADD" complex-instruction , 8-bit-registers sp , "," token hide , 8-bit-registers , ] seq* [ two-params ] action ; : ADD-RR,RR-instruction ( -- parser ) [ "ADD-RR,RR" "ADD" complex-instruction , 16-bit-registers sp , "," token hide , 16-bit-registers , ] seq* [ two-params ] action ; : ADD-R,(RR)-instruction ( -- parser ) [ "ADD-R,(RR)" "ADD" complex-instruction , 8-bit-registers sp , "," token hide , 16-bit-registers indirect , ] seq* [ two-params ] action ; : LD-RR,NN-instruction ( -- parser ) ! LD BC,nn [ "LD-RR,NN" "LD" complex-instruction , 16-bit-registers sp , ",nn" token hide , ] seq* [ one-param ] action ; : LD-R,N-instruction ( -- parser ) ! LD B,n [ "LD-R,N" "LD" complex-instruction , 8-bit-registers sp , ",n" token hide , ] seq* [ one-param ] action ; : LD-(RR),N-instruction ( -- parser ) [ "LD-(RR),N" "LD" complex-instruction , 16-bit-registers indirect sp , ",n" token hide , ] seq* [ one-param ] action ; : LD-(RR),R-instruction ( -- parser ) ! LD (BC),A [ "LD-(RR),R" "LD" complex-instruction , 16-bit-registers indirect sp , "," token hide , 8-bit-registers , ] seq* [ two-params ] action ; : LD-R,R-instruction ( -- parser ) [ "LD-R,R" "LD" complex-instruction , 8-bit-registers sp , "," token hide , 8-bit-registers , ] seq* [ two-params ] action ; : LD-RR,RR-instruction ( -- parser ) [ "LD-RR,RR" "LD" complex-instruction , 16-bit-registers sp , "," token hide , 16-bit-registers , ] seq* [ two-params ] action ; : LD-R,(RR)-instruction ( -- parser ) [ "LD-R,(RR)" "LD" complex-instruction , 8-bit-registers sp , "," token hide , 16-bit-registers indirect , ] seq* [ two-params ] action ; : LD-(NN),RR-instruction ( -- parser ) [ "LD-(NN),RR" "LD" complex-instruction , "nn" token indirect sp hide , "," token hide , 16-bit-registers , ] seq* [ one-param ] action ; : LD-(NN),R-instruction ( -- parser ) [ "LD-(NN),R" "LD" complex-instruction , "nn" token indirect sp hide , "," token hide , 8-bit-registers , ] seq* [ one-param ] action ; : LD-RR,(NN)-instruction ( -- parser ) [ "LD-RR,(NN)" "LD" complex-instruction , 16-bit-registers sp , "," token hide , "nn" token indirect hide , ] seq* [ one-param ] action ; : LD-R,(NN)-instruction ( -- parser ) [ "LD-R,(NN)" "LD" complex-instruction , 8-bit-registers sp , "," token hide , "nn" token indirect hide , ] seq* [ one-param ] action ; : OUT-(N),R-instruction ( -- parser ) [ "OUT-(N),R" "OUT" complex-instruction , "n" token indirect sp hide , "," token hide , 8-bit-registers , ] seq* [ one-param ] action ; : IN-R,(N)-instruction ( -- parser ) [ "IN-R,(N)" "IN" complex-instruction , 8-bit-registers sp , "," token hide , "n" token indirect hide , ] seq* [ one-param ] action ; : EX-(RR),RR-instruction ( -- parser ) [ "EX-(RR),RR" "EX" complex-instruction , 16-bit-registers indirect sp , "," token hide , 16-bit-registers , ] seq* [ two-params ] action ; : EX-RR,RR-instruction ( -- parser ) [ "EX-RR,RR" "EX" complex-instruction , 16-bit-registers sp , "," token hide , 16-bit-registers , ] seq* [ two-params ] action ; : 8080-generator-parser ( -- parser ) [ NOP-instruction , RST-0-instruction , RST-8-instruction , RST-10H-instruction , RST-18H-instruction , RST-20H-instruction , RST-28H-instruction , RST-30H-instruction , RST-38H-instruction , JP-F|FF,NN-instruction , JP-NN-instruction , JP-(RR)-instruction , CALL-F|FF,NN-instruction , CALL-NN-instruction , CPL-instruction , CCF-instruction , SCF-instruction , DAA-instruction , RLA-instruction , RRA-instruction , RLCA-instruction , RRCA-instruction , HALT-instruction , DI-instruction , EI-instruction , AND-N-instruction , AND-R-instruction , AND-(RR)-instruction , XOR-N-instruction , XOR-R-instruction , XOR-(RR)-instruction , OR-N-instruction , OR-R-instruction , OR-(RR)-instruction , CP-N-instruction , CP-R-instruction , CP-(RR)-instruction , DEC-RR-instruction , DEC-R-instruction , DEC-(RR)-instruction , POP-RR-instruction , PUSH-RR-instruction , INC-RR-instruction , INC-R-instruction , INC-(RR)-instruction , LD-RR,NN-instruction , LD-RR,RR-instruction , LD-R,N-instruction , LD-R,R-instruction , LD-(RR),N-instruction , LD-(RR),R-instruction , LD-R,(RR)-instruction , LD-(NN),RR-instruction , LD-(NN),R-instruction , LD-RR,(NN)-instruction , LD-R,(NN)-instruction , ADC-R,(RR)-instruction , ADC-R,N-instruction , ADC-R,R-instruction , ADD-R,N-instruction , ADD-R,(RR)-instruction , ADD-R,R-instruction , ADD-RR,RR-instruction , SBC-R,N-instruction , SBC-R,R-instruction , SBC-R,(RR)-instruction , SUB-R-instruction , SUB-(RR)-instruction , SUB-N-instruction , RET-F|FF-instruction , RET-NN-instruction , OUT-(N),R-instruction , IN-R,(N)-instruction , EX-(RR),RR-instruction , EX-RR,RR-instruction , ] choice* [ call( -- quot ) ] action ; : instruction-quotations ( string -- emulate-quot ) ! Given an instruction string, return the emulation quotation for ! it. This will later be expanded to produce the disassembly and ! assembly quotations. 8080-generator-parser parse ; SYMBOL: last-instruction SYMBOL: last-opcode : parse-instructions ( list -- ) ! Process the list of strings, which should make ! up an 8080 instruction, and output a quotation ! that would implement that instruction. dup " " join instruction-quotations [ "_" join [ "emulate-" % % ] "" make create-word-in dup last-instruction set-global ] dip ( cpu -- ) define-declared ; SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ; SYNTAX: cycles: ! Set the number of cycles for the last instruction that was defined. scan-token string>number last-opcode get-global instruction-cycles set-nth ; SYNTAX: opcode: ! Set the opcode number for the last instruction that was defined. last-instruction get-global 1quotation scan-token hex> dup last-opcode set-global set-instruction ;