diff --git a/contrib/space-invaders/cpu.factor b/contrib/space-invaders/cpu-8080.factor similarity index 81% rename from contrib/space-invaders/cpu.factor rename to contrib/space-invaders/cpu-8080.factor index 3c3da2cd9f..2696f9fc48 100644 --- a/contrib/space-invaders/cpu.factor +++ b/contrib/space-invaders/cpu-8080.factor @@ -2,36 +2,33 @@ USING: kernel lists math sequences errors vectors prettyprint io unparser namesp words parser hashtables lazy parser-combinators kernel-internals strings ; IN: cpu-8080 -TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port2o port3o port4lo port4hi port5o ram display ; +TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; -: valid-byte? ( b -- ) - dup 0 >= swap HEX: FF <= and not [ "Invalid byte" throw ] when ; +GENERIC: reset ( cpu -- ) +GENERIC: update-video ( value addr cpu -- ) +GENERIC: read-port ( port cpu -- byte ) +GENERIC: write-port ( value port cpu -- ) -: valid-word? ( w -- ) - dup 0 >= swap HEX: FFFF <= and not [ "Invalid word" throw ] when ; +M: cpu update-video ( value addr cpu -- ) + 3drop ; + +M: cpu read-port ( port cpu -- byte ) + #! Read a byte from the hardware port. 'port' should + #! be an 8-bit value. + 2drop 0 ; + +M: cpu write-port ( value port cpu -- ) + #! Write a byte to the hardware port, where 'port' is + #! an 8-bit value. + 3drop ; : carry-flag HEX: 01 ; inline -: add-sub-flag HEX: 02 ; inline -: subtraction-flag HEX: 02 ; inline : parity-flag HEX: 04 ; inline -: overflow-flag HEX: 04 ; inline -: flag3-flag HEX: 08 ; inline : half-carry-flag HEX: 10 ; inline -: aux-carry-flag HEX: 10 ; inline : interrupt-flag HEX: 20 ; inline -: flag5-flag HEX: 20 ; inline : zero-flag HEX: 40 ; inline : sign-flag HEX: 80 ; inline -: increment-8bit ( v -- v overflow? ) - #! Increment an 8 bit value by 1. Return the new - #! value plus t if the value overflowed back to zero. - 1 + dup 256 = [ - drop 0 t - ] [ - f - ] ifte ; - : >word< ( word -- byte byte ) #! Explode a word into its two 8 bit values. dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ; @@ -114,13 +111,13 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port cpu-ram nth ] [ 2drop HEX: FF - ] ifte dup valid-byte? ; + ] ifte ; : 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 >r 1 + r> read-byte 8 shift bitor dup valid-word? ; + [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ; : next-byte ( cpu -- byte ) #! Return the value of the byte at PC, and increment PC. @@ -136,23 +133,9 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port [ cpu-pc 2 + ] keep set-cpu-pc ; -: update-video ( value addr cpu -- ) - #! If a 'display' quotation is set for the cpu, call it - #! if the write to RAM is within video memory range. - over HEX: 2400 >= [ - dup cpu-display [ ( value addr cpu quot -- ) - call - ] [ - 3drop - ] ifte* - ] [ - 3drop - ] ifte ; : write-byte ( value addr cpu -- ) #! Write a byte to the specified memory address. - pick valid-byte? - over valid-word? over dup HEX: 2000 < swap HEX: FFFF > or [ 3drop ] [ @@ -163,34 +146,8 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port : write-word ( value addr cpu -- ) #! Write a 16-bit word to the specified memory address. - pick valid-word? >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ; -: read-port ( port cpu -- byte ) - #! Read a byte from the hardware port. 'port' should - #! be an 8-bit value. -! 2dup drop "IN from " write number>string print - { - { [ over 1 = ] [ nip [ cpu-port1 dup HEX: FE bitand ] keep set-cpu-port1 ] } - { [ over 2 = ] [ nip [ cpu-port2i HEX: 8F bitand ] keep cpu-port1 HEX: 70 bitand bitor ] } - { [ over 3 = ] [ nip [ cpu-port4hi 8 shift ] keep [ cpu-port4lo bitor ] keep cpu-port2o shift -8 shift HEX: FF bitand ] } - { [ t ] [ 2drop 0 ] } - } cond dup valid-byte? ; - -: write-port ( value port cpu -- ) - #! Write a byte to the hardware port, where 'port' is - #! an 8-bit value. - pick valid-byte? -! 3dup drop "OUT to " write unparse write " value " write unparse print - { - { [ over 2 = ] [ nip set-cpu-port2o ] } - { [ over 3 = ] [ nip set-cpu-port3o ] } - { [ over 4 = ] [ nip [ cpu-port4hi ] keep [ set-cpu-port4lo ] keep set-cpu-port4hi ] } - { [ over 5 = ] [ nip set-cpu-port5o ] } - { [ over 6 = ] [ 3drop ] } - { [ t ] [ 3drop "Invalid port write" throw ] } - } cond ; - : cpu-a-bitand ( quot cpu -- ) #! A &= quot call [ cpu-a swap call bitand ] keep set-cpu-a ; inline @@ -253,6 +210,7 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port #! is 0, (ie. if the result has even parity) this flag #! is set, otherwise it is reset. swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] ifte ; + : 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 @@ -277,32 +235,6 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port 2dup update-sign-flag update-zero-flag ; -: trigger-zero-flag ( n cpu -- ) - #! Given the value n, set the zero flag if required. - swap HEX: FF bitand 0 = [ [ zero-flag ] swap cpu-f-bitor ] [ drop ] ifte ; - -: trigger-sign-flag ( n cpu -- ) - #! Given the value n, set the sign flag if required. - swap HEX: 80 bitand 0 = not [ [ sign-flag ] swap cpu-f-bitor ] [ drop ] ifte ; - -: trigger-carry-flag ( n cpu -- ) - #! Given the value n, set the carry flag if required. - swap HEX: 100 >= [ [ carry-flag ] swap cpu-f-bitor ] [ drop ] ifte ; - -: trigger-half-carry-flag ( n a+n+cf cpu -- ) - #! Given the value n, set the half carry flag if required. - -rot ( cpu n a+n+cf ) - pick cpu-a bitxor bitxor HEX: 10 bitand 0 = not [ [ half-carry-flag ] swap cpu-f-bitor ] [ drop ] ifte ; - -: trigger-overflow-flag ( n a+n+cf cpu -- ) - #! Given the value n, set the half carry flag if required. - -rot ( cpu n a+n+cf ) - over bitxor ( cpu n x^n ) - pick cpu-a rot bitxor ( cpu x^n a^n ) - bitand HEX: 80 bitand ( cpu v ) - 0 = not [ [ overflow-flag ] swap cpu-f-bitor ] [ drop ] ifte ; - - : add-byte ( lhs rhs cpu -- result ) #! Add rhs to lhs >r + r> [ update-flags ] 2keep drop HEX: FF bitand ; @@ -380,270 +312,6 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port : flags ( seq -- seq ) [ 0 [ execute bitor ] reduce ] map ; -SYMBOL: psz-vector - -: psz ( -- vector ) - psz-vector get ; - -{ - [ zero-flag parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ ] - [ parity-flag ] - [ ] - [ parity-flag ] - [ parity-flag ] - [ ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] - [ sign-flag ] - [ sign-flag ] - [ sign-flag parity-flag ] -} flags psz-vector set - : decrement-sp ( n cpu -- ) #! Decrement the stackpointer by n. [ cpu-sp ] keep @@ -678,56 +346,12 @@ SYMBOL: psz-vector : call-sub ( addr cpu -- ) #! Call the address as a subroutine. - over valid-word? dup push-pc >r HEX: FFFF bitand r> set-cpu-pc ; -: clear-and-set-flags-psz ( cpu -- ) - [ cpu-f flag3-flag flag5-flag bitor bitand ] keep - [ cpu-a psz nth bitor ] keep ( v cpu -- ) - set-cpu-f ; - -: dec-byte-old ( b cpu -- b ) - over valid-byte? - [ - cpu-f - zero-flag sign-flag half-carry-flag overflow-flag bitor bitor bitor - 255 swap - bitand - add-sub-flag bitor - ] keep - [ set-cpu-f ] keep ( b cpu -- ) - [ swap HEX: 0f bitand 0 = [ [ half-carry-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - >r 1 - HEX: FF bitand r> - [ swap HEX: 7F = [ [ overflow-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - [ swap HEX: 80 bitand 0 = not [ [ sign-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - [ swap HEX: 00 = [ [ zero-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - drop dup valid-byte? ; - : ret-from-sub ( cpu -- ) [ pop-pc ] keep set-cpu-pc ; - -: set-flags-psz ( cpu -- ) - [ cpu-f parity-flag sign-flag zero-flag bitor bitor 255 swap - bitand ] keep - [ cpu-a psz nth bitor ] keep ( v cpu -- ) - set-cpu-f ; - -SYMBOL: cf - -: sub-byte-old ( cf n cpu -- x ) - #! Subtracts 'n' from the 'a' register. 'cf' is carry flag settings. - over valid-byte? - pick cf set - [ rot drop cpu-a swap - HEX: FF bitand ] 3keep ( x cf n cpu ) - rot 0 = not [ >r >r 1 - HEX: FF bitand r> r> ] when ( x n cpu ) - [ cpu-f flag3-flag flag5-flag bitor bitand subtraction-flag bitor ] keep ( x n f cpu ) - [ set-cpu-f ] keep swapd ( n x cpu ) - [ swap 0 = [ [ zero-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - [ swap HEX: 80 bitand 0 = not [ [ sign-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 2keep - [ swap over cpu-a >= ( n cpu >= ) rot cf get bitor 0 = not and [ [ carry-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 3keep - [ dup >r cpu-a bitxor bitxor HEX: 10 bitand r> swap 0 = not [ [ half-carry-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 3keep - [ dup >r cpu-a swapd bitxor swap r> dup >r cpu-a bitxor bitand HEX: 80 bitand r> swap 0 = not [ [ overflow-flag ] swap cpu-f-bitor ] [ drop ] ifte ] 3keep - drop nip dup valid-byte? ; - + : interrupt ( number cpu -- ) #! Perform a hardware interrupt ! "***Interrupt: " write over 16 >base print @@ -742,7 +366,7 @@ SYMBOL: cf #! Increment the number of cpu cycles [ cpu-cycles + ] keep set-cpu-cycles ; -: instruction-cycles ( -- ) +: instruction-cycles ( -- vector ) #! Return a 256 element vector containing the cycles for #! each opcode in the 8080 instruction set. { @@ -755,7 +379,7 @@ SYMBOL: cf f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; -: instructions ( -- ) +: instructions ( -- vector ) #! Return a 256 element vector containing the emulation words for #! each opcode in the 8080 instruction set. { @@ -766,9 +390,9 @@ SYMBOL: cf f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; + f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; inline -: reset ( cpu -- ) +M: cpu reset ( cpu -- ) #! Reset the CPU to its poweron state [ 0 swap set-cpu-b ] keep [ 0 swap set-cpu-c ] keep @@ -783,16 +407,9 @@ SYMBOL: cf [ HEX: FFFF 0 >vector swap set-cpu-ram ] keep [ f swap set-cpu-halted? ] keep [ HEX: 10 swap set-cpu-last-interrupt ] keep - [ 0 swap set-cpu-port1 ] keep - [ 0 swap set-cpu-port2i ] keep - [ 0 swap set-cpu-port2o ] keep - [ 0 swap set-cpu-port3o ] keep - [ 0 swap set-cpu-port4lo ] keep - [ 0 swap set-cpu-port4hi ] keep - [ 0 swap set-cpu-port5o ] keep 0 swap set-cpu-cycles ; -C: cpu ( -- cpu ) +C: cpu ( cpu -- cpu ) [ reset ] keep ; : (load-rom) ( n ram -- ) @@ -964,40 +581,53 @@ SYMBOL: $4 set-cpu-pc ; : (emulate-RLCA) ( cpu -- ) - dup cpu-a dup ( cpu a a ) - 1 shift HEX: FF bitand swap -7 shift HEX: FF bitand bitor ( cpu a ) - HEX: FF bitand dup pick set-cpu-a - add-sub-flag half-carry-flag carry-flag bitor bitor HEX: FF swap - ( cpu a newf ) - pick cpu-f bitand pick set-cpu-f - HEX: 01 bitand 0 = not [ dup cpu-f carry-flag bitor swap set-cpu-f ] [ drop ] ifte ; + #! The content of the accumulator is rotated left + #! one position. The low order bit and the carry flag + #! are both set to the value shifted out of the high + #! order bit position. Only the carry flag is affected. + [ cpu-a -7 shift ] keep + over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte + [ cpu-a 1 shift HEX: FF bitand ] keep + >r bitor r> set-cpu-a ; : (emulate-RRCA) ( cpu -- ) - dup cpu-a dup ( cpu a a ) - -1 shift HEX: FF bitand swap 7 shift HEX: FF bitand bitor ( cpu a ) - HEX: FF bitand dup pick set-cpu-a - add-sub-flag half-carry-flag carry-flag bitor bitor HEX: FF swap - ( cpu a newf ) - pick cpu-f bitand pick set-cpu-f - HEX: 80 bitand 0 = not [ dup cpu-f carry-flag bitor swap set-cpu-f ] [ drop ] ifte ; + #! The content of the accumulator is rotated right + #! one position. The high order bit and the carry flag + #! are both set to the value shifted out of the low + #! order bit position. Only the carry flag is affected. + [ cpu-a 1 bitand 7 shift ] keep + over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte + [ cpu-a 254 bitand -1 shift ] keep + >r bitor r> set-cpu-a ; : (emulate-RLA) ( cpu -- ) - dup cpu-a dup ( cpu old-a new-a ) - 1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a ) - over flag-c? [ [ 1 ] pick cpu-a-bitor ] when - [ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand - HEX: 80 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when - drop ; + #! 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 shifted out + #! of the high order bit. Only the carry flag is + #! affected. + [ carry-flag swap flag-set? [ 1 ] [ 0 ] ifte ] keep + [ cpu-a 127 bitand 7 shift ] keep + dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte + >r bitor r> set-cpu-a ; : (emulate-RRA) ( cpu -- ) - dup cpu-a dup ( cpu old-a new-a ) - -1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a ) - over flag-c? [ [ HEX: 80 ] pick cpu-a-bitor ] when - [ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand - HEX: 01 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when - drop ; + #! 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 shifted out of the low order bit. + #! Only the carry flag is affected. + [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] ifte ] keep + [ cpu-a 254 bitand -1 shift ] keep + dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte + >r bitor r> set-cpu-a ; : (emulate-CPL) ( cpu -- ) - [ HEX: FF ] over cpu-a-bitxor - [ add-sub-flag half-carry-flag bitor ] swap cpu-f-bitor ; + #! The contents of the accumulator are complemented + #! (zero bits become one, one bits becomes zero). + #! No flags are affected. + HEX: FF swap cpu-a-bitxor= ; : (emulate-DAA) ( cpu -- ) #! The eight bit number in the accumulator is @@ -1032,9 +662,9 @@ SYMBOL: $4 [[ "RST-30H" [ drop "RST 30H Not Implemented" throw ] ]] [[ "RST-38H" [ drop "RST 38H Not Implemented" throw ] ]] [[ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] ifte ] ]] - [[ "CP-N" [ [ next-byte ] keep 0 -rot sub-byte-old drop ] ]] - [[ "CP-R" [ [ $1 ] keep 0 -rot sub-byte-old drop ] ]] - [[ "CP-(RR)" [ [ $1 ] keep [ read-byte ] keep 0 -rot sub-byte-old drop ] ]] + [[ "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] ]] + [[ "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] ]] + [[ "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] ]] [[ "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] ]] [[ "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] ]] [[ "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] ]] diff --git a/contrib/space-invaders/gui.factor b/contrib/space-invaders/gui.factor deleted file mode 100644 index c5bac5794b..0000000000 --- a/contrib/space-invaders/gui.factor +++ /dev/null @@ -1,131 +0,0 @@ -IN: cpu-8080 -USING: kernel lists sdl sdl-event sdl-gfx sdl-video math styles sequences io namespaces generic kernel-internals ; - -: plot-bits ( h w byte bit -- ) - dup swapd -1 * shift 1 bitand 0 = [ ( h w bit -- ) - swap 8 * + surface get -rot swap black rgb pixelColor - ] [ - swap 8 * + surface get -rot swap white rgb pixelColor - ] ifte ; - -: update-display ( cpu -- ) - 224 [ ( cpu h -- h ) - 32 [ ( cpu h w -- w ) - [ swap 32 * + HEX: 2400 + swap cpu-ram nth ] 3keep ( byte cpu h w ) - rot >r rot ( h w byte ) - [ 0 plot-bits ] 3keep - [ 1 plot-bits ] 3keep - [ 2 plot-bits ] 3keep - [ 3 plot-bits ] 3keep - [ 4 plot-bits ] 3keep - [ 5 plot-bits ] 3keep - [ 6 plot-bits ] 3keep - [ 7 plot-bits ] 3keep - drop r> -rot - ] repeat - ] repeat drop ; - -: gui-step ( cpu -- ) - [ read-instruction ] keep ( n cpu ) - over get-cycles over inc-cycles - [ swap instructions dispatch ] keep - [ cpu-pc HEX: FFFF bitand ] keep - set-cpu-pc ; - -: gui-frame/2 ( cpu -- ) - [ gui-step ] keep - [ cpu-cycles ] keep - over 16667 < [ ( cycles cpu ) - nip gui-frame/2 - ] [ - [ >r 16667 - r> set-cpu-cycles ] keep - dup cpu-last-interrupt HEX: 10 = [ - HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt - ] [ - HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt - ] ifte - ] ifte ; - -: gui-frame ( cpu -- ) - dup gui-frame/2 gui-frame/2 ; - -GENERIC: handle-si-event ( cpu event -- quit? ) - -M: object handle-si-event ( cpu event -- quit? ) - 2drop f ; - -M: quit-event handle-si-event ( cpu event -- quit? ) - 2drop t ; - -USE: prettyprint - -M: key-down-event handle-si-event ( cpu event -- quit? ) - keyboard-event>binding last car ( cpu key ) - { - { [ dup "ESCAPE" = ] [ 2drop t ] } - { [ dup "BACKSPACE" = ] [ drop [ cpu-port1 1 bitor ] keep set-cpu-port1 f ] } - { [ dup 1 = ] [ drop [ cpu-port1 4 bitor ] keep set-cpu-port1 f ] } - { [ dup "LCTRL" = ] [ drop [ cpu-port1 HEX: 10 bitor ] keep set-cpu-port1 f ] } - { [ dup "LEFT" = ] [ drop [ cpu-port1 HEX: 20 bitor ] keep set-cpu-port1 f ] } - { [ dup "RIGHT" = ] [ drop [ cpu-port1 HEX: 40 bitor ] keep set-cpu-port1 f ] } - { [ t ] [ . drop f ] } - } cond ; - -M: key-up-event handle-si-event ( cpu event -- quit? ) - keyboard-event>binding last car ( cpu key ) - { - { [ dup "ESCAPE" = ] [ 2drop t ] } - { [ dup "BACKSPACE" = ] [ drop [ cpu-port1 255 1 - bitand ] keep set-cpu-port1 f ] } - { [ dup 1 = ] [ drop [ cpu-port1 255 4 - bitand ] keep set-cpu-port1 f ] } - { [ dup "LCTRL" = ] [ drop [ cpu-port1 255 HEX: 10 - bitand ] keep set-cpu-port1 f ] } - { [ dup "LEFT" = ] [ drop [ cpu-port1 255 HEX: 20 - bitand ] keep set-cpu-port1 f ] } - { [ dup "RIGHT" = ] [ drop [ cpu-port1 255 HEX: 40 - bitand ] keep set-cpu-port1 f ] } - { [ t ] [ . drop f ] } - } cond ; - -: event-loop ( cpu event -- ) - dup SDL_PollEvent [ - 2dup handle-si-event [ - 2drop - ] [ - event-loop - ] ifte - ] [ - [ over gui-frame ] with-surface -! [ -! over update-display -! ] with-surface - event-loop - ] ifte ; - -: addr>xy ( addr -- x y ) - #! Convert video RAM address to base X Y value - HEX: 2400 - ( n ) - dup HEX: 1f bitand 8 * 255 swap - ( n y ) - swap -5 shift swap ; - - -: plot-bits2 ( x y byte bit -- ) - dup swapd -1 * shift 1 bitand 0 = [ ( x y bit -- ) - - surface get -rot black rgb pixelColor - ] [ - - surface get -rot white rgb pixelColor - ] ifte ; - -: do-video-update ( value addr cpu -- ) - drop addr>xy rot ( x y value ) - [ 0 plot-bits2 ] 3keep - [ 1 plot-bits2 ] 3keep - [ 2 plot-bits2 ] 3keep - [ 3 plot-bits2 ] 3keep - [ 4 plot-bits2 ] 3keep - [ 5 plot-bits2 ] 3keep - [ 6 plot-bits2 ] 3keep - 7 plot-bits2 ; - -: display ( -- ) - 224 256 0 SDL_HWSURFACE [ - test-cpu [ do-video-update ] over set-cpu-display dup - event-loop - SDL_Quit - ] with-screen ; diff --git a/contrib/space-invaders/load.factor b/contrib/space-invaders/load.factor index bc33408e8a..6fd5772e46 100644 --- a/contrib/space-invaders/load.factor +++ b/contrib/space-invaders/load.factor @@ -1,7 +1,11 @@ IN: scratchpad -USE: parser +USING: parser compiler words sequences io ; "../parser-combinators/lazy.factor" run-file "../parser-combinators/parser-combinators.factor" run-file -"cpu.factor" run-file -! "tests.factor" run-file +"cpu-8080.factor" run-file +"space-invaders.factor" run-file + +"cpu-8080" words [ try-compile ] each + +"Use 'run' in the 'space-invaders' vocabulary to start." print \ No newline at end of file diff --git a/contrib/space-invaders/readme.txt b/contrib/space-invaders/readme.txt index add2e0af73..6a5dae5470 100644 --- a/contrib/space-invaders/readme.txt +++ b/contrib/space-invaders/readme.txt @@ -2,27 +2,18 @@ This is a first cut at a simple space invaders emulator. The goal is to produce an emulator, disassembler and assembler for the 8080 processor. -Running 'load.factor' will load the CPU emulation routines and -supporting code. Run 'gui.factor' to get the SDL based GUI code. +Running 'load.factor' will load all necessary files to run the game. If you are in the space-invaders directory, and have the ROM as a file 'invaders.rom' in that same directory, the following starts the GUI: "load.factor" run-file - "gui.factor" run-file - USE: cpu-8080 - display + USE: space-invaders + run -This will run the emulator in interpreted mode. To compile the Factor -code do the following: - - "cpu-8080" words [ try-compile ] each - display - -This will run much faster. - -'Backspace' inserts a coin and '1' is the one player button. The left -and right arrow keys move and the left control key fires. +'Backspace' inserts a coin, '1' is the one player button and '2' is +the two play button. The left and right arrow keys move and the left +control key fires. If the ROM file you have is split into seperate files, you will need to merge them into one 'invaders.rom' file. From Windows this is done @@ -34,5 +25,12 @@ Or Linux: cat invaders.h invaders.g invaders.f invaders.e >invaders.rom +The emulator is actually a generic Intel 8080 and the code for this is +in cpu-8080.factor. The space invaders specific code is in +space-invaders.factor. It specializes generic functions defined by the +8080 emulator code to handle the space invaders display and +input/output ports. + For more information, contact the author, Chris Double, at -chris.double@double.co.nz or from my weblog http://radio.weblogs.com/0102385 \ No newline at end of file +chris.double@double.co.nz or from my weblog +http://radio.weblogs.com/0102385 diff --git a/contrib/space-invaders/space-invaders.factor b/contrib/space-invaders/space-invaders.factor new file mode 100644 index 0000000000..69dc4bb9f1 --- /dev/null +++ b/contrib/space-invaders/space-invaders.factor @@ -0,0 +1,172 @@ +IN: space-invaders +USING: cpu-8080 kernel lists sdl sdl-event sdl-gfx sdl-video math styles sequences io namespaces generic kernel-internals threads errors ; + +TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o ; + +C: space-invaders ( cpu -- cpu ) + [ swap set-delegate ] keep + [ reset ] keep ; + +M: space-invaders read-port ( port cpu -- byte ) + #! Read a byte from the hardware port. 'port' should + #! be an 8-bit value. + { + { [ over 1 = ] [ nip [ space-invaders-port1 dup HEX: FE bitand ] keep set-space-invaders-port1 ] } + { [ over 2 = ] [ nip [ space-invaders-port2i HEX: 8F bitand ] keep space-invaders-port1 HEX: 70 bitand bitor ] } + { [ over 3 = ] [ nip [ space-invaders-port4hi 8 shift ] keep [ space-invaders-port4lo bitor ] keep space-invaders-port2o shift -8 shift HEX: FF bitand ] } + { [ t ] [ 2drop 0 ] } + } cond ; + +M: space-invaders write-port ( value port cpu -- ) + #! Write a byte to the hardware port, where 'port' is + #! an 8-bit value. + { + { [ over 2 = ] [ nip set-space-invaders-port2o ] } + { [ over 3 = ] [ nip set-space-invaders-port3o ] } + { [ over 4 = ] [ nip [ space-invaders-port4hi ] keep [ set-space-invaders-port4lo ] keep set-space-invaders-port4hi ] } + { [ over 5 = ] [ nip set-space-invaders-port5o ] } + { [ over 6 = ] [ 3drop ] } + { [ t ] [ 3drop "Invalid port write" throw ] } + } cond ; + +M: space-invaders reset ( cpu -- ) + [ delegate reset ] keep + [ 0 swap set-space-invaders-port1 ] keep + [ 0 swap set-space-invaders-port2i ] keep + [ 0 swap set-space-invaders-port2o ] keep + [ 0 swap set-space-invaders-port3o ] keep + [ 0 swap set-space-invaders-port4lo ] keep + [ 0 swap set-space-invaders-port4hi ] keep + 0 swap set-space-invaders-port5o ; + +: gui-step ( cpu -- ) + [ read-instruction ] keep ( n cpu ) + over get-cycles over inc-cycles + [ swap instructions dispatch ] keep + [ cpu-pc HEX: FFFF bitand ] keep + set-cpu-pc ; + +: gui-frame/2 ( cpu -- ) + [ gui-step ] keep + [ cpu-cycles ] keep + over 16667 < [ ( cycles cpu ) + nip gui-frame/2 + ] [ + [ >r 16667 - r> set-cpu-cycles ] keep + dup cpu-last-interrupt HEX: 10 = [ + HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt + ] [ + HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt + ] ifte + ] ifte ; + +: gui-frame ( cpu -- ) + dup gui-frame/2 gui-frame/2 ; + +GENERIC: handle-si-event ( cpu event -- quit? ) + +M: object handle-si-event ( cpu event -- quit? ) + 2drop f ; + +M: quit-event handle-si-event ( cpu event -- quit? ) + 2drop t ; + +USE: prettyprint + +M: key-down-event handle-si-event ( cpu event -- quit? ) + keyboard-event>binding last car ( cpu key ) + { + { [ dup "ESCAPE" = ] [ 2drop t ] } + { [ dup "BACKSPACE" = ] [ drop [ space-invaders-port1 1 bitor ] keep set-space-invaders-port1 f ] } + { [ dup 1 = ] [ drop [ space-invaders-port1 4 bitor ] keep set-space-invaders-port1 f ] } + { [ dup 2 = ] [ drop [ space-invaders-port1 2 bitor ] keep set-space-invaders-port1 f ] } + { [ dup "LCTRL" = ] [ drop [ space-invaders-port1 HEX: 10 bitor ] keep set-space-invaders-port1 f ] } + { [ dup "LEFT" = ] [ drop [ space-invaders-port1 HEX: 20 bitor ] keep set-space-invaders-port1 f ] } + { [ dup "RIGHT" = ] [ drop [ space-invaders-port1 HEX: 40 bitor ] keep set-space-invaders-port1 f ] } + { [ t ] [ . drop f ] } + } cond ; + +M: key-up-event handle-si-event ( cpu event -- quit? ) + keyboard-event>binding last car ( cpu key ) + { + { [ dup "ESCAPE" = ] [ 2drop t ] } + { [ dup "BACKSPACE" = ] [ drop [ space-invaders-port1 255 1 - bitand ] keep set-space-invaders-port1 f ] } + { [ dup 1 = ] [ drop [ space-invaders-port1 255 4 - bitand ] keep set-space-invaders-port1 f ] } + { [ dup 2 = ] [ drop [ space-invaders-port1 255 2 - bitand ] keep set-space-invaders-port1 f ] } + { [ dup "LCTRL" = ] [ drop [ space-invaders-port1 255 HEX: 10 - bitand ] keep set-space-invaders-port1 f ] } + { [ dup "LEFT" = ] [ drop [ space-invaders-port1 255 HEX: 20 - bitand ] keep set-space-invaders-port1 f ] } + { [ dup "RIGHT" = ] [ drop [ space-invaders-port1 255 HEX: 40 - bitand ] keep set-space-invaders-port1 f ] } + { [ t ] [ . drop f ] } + } cond ; + +: sync-frame ( millis -- millis ) + #! Sleep until the time for the next frame arrives. + 1000 60 / >fixnum + millis - dup 0 > [ sleep ] [ drop ] ifte millis ; + +: (event-loop) ( millis cpu event -- ) + dup SDL_PollEvent [ + 2dup handle-si-event [ + 3drop + ] [ + (event-loop) + ] ifte + ] [ + >r >r sync-frame r> r> + [ over gui-frame ] with-surface + (event-loop) + ] ifte ; + +: event-loop ( cpu event -- ) + millis -rot (event-loop) ; + +: addr>xy ( addr -- x y ) + #! Convert video RAM address to base X Y value + HEX: 2400 - ( n ) + dup HEX: 1f bitand 8 * 255 swap - ( n y ) + swap -5 shift swap ; + +: within ( n a b - bool ) + #! n >= a and n <= b + rot tuck swap <= >r swap >= r> and ; + +: color ( x y -- color ) + #! Return the color to use for the given x/y position. + { + { [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] } + { [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] } + { [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] } + { [ t ] [ 2drop white ] } + } cond ; + +: plot-bits ( x y byte bit -- ) + dup swapd -1 * shift 1 bitand 0 = [ ( x y bit -- ) + - surface get -rot black rgb pixelColor + ] [ + - surface get -rot 2dup color rgb pixelColor + ] ifte ; + +: do-video-update ( value addr cpu -- ) + drop addr>xy rot ( x y value ) + [ 0 plot-bits ] 3keep + [ 1 plot-bits ] 3keep + [ 2 plot-bits ] 3keep + [ 3 plot-bits ] 3keep + [ 4 plot-bits ] 3keep + [ 5 plot-bits ] 3keep + [ 6 plot-bits ] 3keep + 7 plot-bits ; + +M: space-invaders update-video ( value addr cpu -- ) + over HEX: 2400 >= [ + do-video-update + ] [ + 3drop + ] ifte ; + +: run ( -- ) + 224 256 0 SDL_HWSURFACE [ + "invaders.rom" over load-rom + event-loop + SDL_Quit + ] with-screen ; +