space invaders: sync frame rate. reorganise code into generic 8080 and space invaders portions. remove dead
code.cvs
Chris Double
parent
d0312300b8
commit
dede7e0dba
|
|
@ -2,36 +2,33 @@ USING: kernel lists math sequences errors vectors prettyprint io unparser namesp
|
||||||
words parser hashtables lazy parser-combinators kernel-internals strings ;
|
words parser hashtables lazy parser-combinators kernel-internals strings ;
|
||||||
IN: cpu-8080
|
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 -- )
|
GENERIC: reset ( cpu -- )
|
||||||
dup 0 >= swap HEX: FF <= and not [ "Invalid byte" throw ] when ;
|
GENERIC: update-video ( value addr cpu -- )
|
||||||
|
GENERIC: read-port ( port cpu -- byte )
|
||||||
|
GENERIC: write-port ( value port cpu -- )
|
||||||
|
|
||||||
: valid-word? ( w -- )
|
M: cpu update-video ( value addr cpu -- )
|
||||||
dup 0 >= swap HEX: FFFF <= and not [ "Invalid word" throw ] when ;
|
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
|
: carry-flag HEX: 01 ; inline
|
||||||
: add-sub-flag HEX: 02 ; inline
|
|
||||||
: subtraction-flag HEX: 02 ; inline
|
|
||||||
: parity-flag HEX: 04 ; inline
|
: parity-flag HEX: 04 ; inline
|
||||||
: overflow-flag HEX: 04 ; inline
|
|
||||||
: flag3-flag HEX: 08 ; inline
|
|
||||||
: half-carry-flag HEX: 10 ; inline
|
: half-carry-flag HEX: 10 ; inline
|
||||||
: aux-carry-flag HEX: 10 ; inline
|
|
||||||
: interrupt-flag HEX: 20 ; inline
|
: interrupt-flag HEX: 20 ; inline
|
||||||
: flag5-flag HEX: 20 ; inline
|
|
||||||
: zero-flag HEX: 40 ; inline
|
: zero-flag HEX: 40 ; inline
|
||||||
: sign-flag HEX: 80 ; 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 )
|
: >word< ( word -- byte byte )
|
||||||
#! Explode a word into its two 8 bit values.
|
#! Explode a word into its two 8 bit values.
|
||||||
dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
|
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
|
cpu-ram nth
|
||||||
] [
|
] [
|
||||||
2drop HEX: FF
|
2drop HEX: FF
|
||||||
] ifte dup valid-byte? ;
|
] ifte ;
|
||||||
|
|
||||||
: read-word ( addr cpu -- word )
|
: read-word ( addr cpu -- word )
|
||||||
#! Read a 16-bit word from memory at the specified address.
|
#! Read a 16-bit word from memory at the specified address.
|
||||||
#! The address is 16-bit, but if a value greater than
|
#! The address is 16-bit, but if a value greater than
|
||||||
#! 0xFFFF is provided then return a default value.
|
#! 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 )
|
: next-byte ( cpu -- byte )
|
||||||
#! Return the value of the byte at PC, and increment PC.
|
#! 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
|
[ cpu-pc 2 + ] keep
|
||||||
set-cpu-pc ;
|
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-byte ( value addr cpu -- )
|
||||||
#! Write a byte to the specified memory address.
|
#! Write a byte to the specified memory address.
|
||||||
pick valid-byte?
|
|
||||||
over valid-word?
|
|
||||||
over dup HEX: 2000 < swap HEX: FFFF > or [
|
over dup HEX: 2000 < swap HEX: FFFF > or [
|
||||||
3drop
|
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-word ( value addr cpu -- )
|
||||||
#! Write a 16-bit word to the specified memory address.
|
#! 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 ;
|
>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 -- )
|
: cpu-a-bitand ( quot cpu -- )
|
||||||
#! A &= quot call
|
#! A &= quot call
|
||||||
[ cpu-a swap call bitand ] keep set-cpu-a ; inline
|
[ 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 0, (ie. if the result has even parity) this flag
|
||||||
#! is set, otherwise it is reset.
|
#! is set, otherwise it is reset.
|
||||||
swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] ifte ;
|
swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] ifte ;
|
||||||
|
|
||||||
: update-carry-flag ( result cpu -- )
|
: update-carry-flag ( result cpu -- )
|
||||||
#! If the instruction resulted in a carry (from addition)
|
#! If the instruction resulted in a carry (from addition)
|
||||||
#! or a borrow (from subtraction or a comparison) out of the
|
#! 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
|
2dup update-sign-flag
|
||||||
update-zero-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-byte ( lhs rhs cpu -- result )
|
||||||
#! Add rhs to lhs
|
#! Add rhs to lhs
|
||||||
>r + r> [ update-flags ] 2keep drop HEX: FF bitand ;
|
>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 )
|
: flags ( seq -- seq )
|
||||||
[ 0 [ execute bitor ] reduce ] map ;
|
[ 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-sp ( n cpu -- )
|
||||||
#! Decrement the stackpointer by n.
|
#! Decrement the stackpointer by n.
|
||||||
[ cpu-sp ] keep
|
[ cpu-sp ] keep
|
||||||
|
|
@ -678,56 +346,12 @@ SYMBOL: psz-vector
|
||||||
|
|
||||||
: call-sub ( addr cpu -- )
|
: call-sub ( addr cpu -- )
|
||||||
#! Call the address as a subroutine.
|
#! Call the address as a subroutine.
|
||||||
over valid-word?
|
|
||||||
dup push-pc
|
dup push-pc
|
||||||
>r HEX: FFFF bitand r> set-cpu-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 -- )
|
: ret-from-sub ( cpu -- )
|
||||||
[ pop-pc ] keep set-cpu-pc ;
|
[ 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 -- )
|
: interrupt ( number cpu -- )
|
||||||
#! Perform a hardware interrupt
|
#! Perform a hardware interrupt
|
||||||
! "***Interrupt: " write over 16 >base print
|
! "***Interrupt: " write over 16 >base print
|
||||||
|
|
@ -742,7 +366,7 @@ SYMBOL: cf
|
||||||
#! Increment the number of cpu cycles
|
#! Increment the number of cpu cycles
|
||||||
[ cpu-cycles + ] keep set-cpu-cycles ;
|
[ cpu-cycles + ] keep set-cpu-cycles ;
|
||||||
|
|
||||||
: instruction-cycles ( -- )
|
: instruction-cycles ( -- vector )
|
||||||
#! Return a 256 element vector containing the cycles for
|
#! Return a 256 element vector containing the cycles for
|
||||||
#! each opcode in the 8080 instruction set.
|
#! 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
|
||||||
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
|
#! Return a 256 element vector containing the emulation words for
|
||||||
#! each opcode in the 8080 instruction set.
|
#! 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
|
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
|
#! Reset the CPU to its poweron state
|
||||||
[ 0 swap set-cpu-b ] keep
|
[ 0 swap set-cpu-b ] keep
|
||||||
[ 0 swap set-cpu-c ] keep
|
[ 0 swap set-cpu-c ] keep
|
||||||
|
|
@ -783,16 +407,9 @@ SYMBOL: cf
|
||||||
[ HEX: FFFF 0 <repeated> >vector swap set-cpu-ram ] keep
|
[ HEX: FFFF 0 <repeated> >vector swap set-cpu-ram ] keep
|
||||||
[ f swap set-cpu-halted? ] keep
|
[ f swap set-cpu-halted? ] keep
|
||||||
[ HEX: 10 swap set-cpu-last-interrupt ] 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 ;
|
0 swap set-cpu-cycles ;
|
||||||
|
|
||||||
C: cpu ( -- cpu )
|
C: cpu ( cpu -- cpu )
|
||||||
[ reset ] keep ;
|
[ reset ] keep ;
|
||||||
|
|
||||||
: (load-rom) ( n ram -- )
|
: (load-rom) ( n ram -- )
|
||||||
|
|
@ -964,40 +581,53 @@ SYMBOL: $4
|
||||||
set-cpu-pc ;
|
set-cpu-pc ;
|
||||||
|
|
||||||
: (emulate-RLCA) ( cpu -- )
|
: (emulate-RLCA) ( cpu -- )
|
||||||
dup cpu-a dup ( cpu a a )
|
#! The content of the accumulator is rotated left
|
||||||
1 shift HEX: FF bitand swap -7 shift HEX: FF bitand bitor ( cpu a )
|
#! one position. The low order bit and the carry flag
|
||||||
HEX: FF bitand dup pick set-cpu-a
|
#! are both set to the value shifted out of the high
|
||||||
add-sub-flag half-carry-flag carry-flag bitor bitor HEX: FF swap - ( cpu a newf )
|
#! order bit position. Only the carry flag is affected.
|
||||||
pick cpu-f bitand pick set-cpu-f
|
[ cpu-a -7 shift ] keep
|
||||||
HEX: 01 bitand 0 = not [ dup cpu-f carry-flag bitor swap set-cpu-f ] [ drop ] ifte ;
|
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 -- )
|
: (emulate-RRCA) ( cpu -- )
|
||||||
dup cpu-a dup ( cpu a a )
|
#! The content of the accumulator is rotated right
|
||||||
-1 shift HEX: FF bitand swap 7 shift HEX: FF bitand bitor ( cpu a )
|
#! one position. The high order bit and the carry flag
|
||||||
HEX: FF bitand dup pick set-cpu-a
|
#! are both set to the value shifted out of the low
|
||||||
add-sub-flag half-carry-flag carry-flag bitor bitor HEX: FF swap - ( cpu a newf )
|
#! order bit position. Only the carry flag is affected.
|
||||||
pick cpu-f bitand pick set-cpu-f
|
[ cpu-a 1 bitand 7 shift ] keep
|
||||||
HEX: 80 bitand 0 = not [ dup cpu-f carry-flag bitor swap set-cpu-f ] [ drop ] ifte ;
|
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 -- )
|
: (emulate-RLA) ( cpu -- )
|
||||||
dup cpu-a dup ( cpu old-a new-a )
|
#! The content of the accumulator is rotated left
|
||||||
1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a )
|
#! one position through the carry flag. The low
|
||||||
over flag-c? [ [ 1 ] pick cpu-a-bitor ] when
|
#! order bit is set equal to the carry flag and
|
||||||
[ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand
|
#! the carry flag is set to the value shifted out
|
||||||
HEX: 80 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when
|
#! of the high order bit. Only the carry flag is
|
||||||
drop ;
|
#! 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 -- )
|
: (emulate-RRA) ( cpu -- )
|
||||||
dup cpu-a dup ( cpu old-a new-a )
|
#! The content of the accumulator is rotated right
|
||||||
-1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a )
|
#! one position through the carry flag. The high order
|
||||||
over flag-c? [ [ HEX: 80 ] pick cpu-a-bitor ] when
|
#! bit is set to the carry flag and the carry flag is
|
||||||
[ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand
|
#! set to the value shifted out of the low order bit.
|
||||||
HEX: 01 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when
|
#! Only the carry flag is affected.
|
||||||
drop ;
|
[ 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 -- )
|
: (emulate-CPL) ( cpu -- )
|
||||||
[ HEX: FF ] over cpu-a-bitxor
|
#! The contents of the accumulator are complemented
|
||||||
[ add-sub-flag half-carry-flag bitor ] swap cpu-f-bitor ;
|
#! (zero bits become one, one bits becomes zero).
|
||||||
|
#! No flags are affected.
|
||||||
|
HEX: FF swap cpu-a-bitxor= ;
|
||||||
|
|
||||||
: (emulate-DAA) ( cpu -- )
|
: (emulate-DAA) ( cpu -- )
|
||||||
#! The eight bit number in the accumulator is
|
#! The eight bit number in the accumulator is
|
||||||
|
|
@ -1032,9 +662,9 @@ SYMBOL: $4
|
||||||
[[ "RST-30H" [ drop "RST 30H Not Implemented" throw ] ]]
|
[[ "RST-30H" [ drop "RST 30H Not Implemented" throw ] ]]
|
||||||
[[ "RST-38H" [ drop "RST 38H 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 ] ]]
|
[[ "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-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] ]]
|
||||||
[[ "CP-R" [ [ $1 ] keep 0 -rot sub-byte-old drop ] ]]
|
[[ "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] ]]
|
||||||
[[ "CP-(RR)" [ [ $1 ] keep [ read-byte ] keep 0 -rot sub-byte-old 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-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-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 ] ]]
|
[[ "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] ]]
|
||||||
|
|
@ -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> event-loop
|
|
||||||
SDL_Quit
|
|
||||||
] with-screen ;
|
|
||||||
|
|
@ -1,7 +1,11 @@
|
||||||
IN: scratchpad
|
IN: scratchpad
|
||||||
USE: parser
|
USING: parser compiler words sequences io ;
|
||||||
|
|
||||||
"../parser-combinators/lazy.factor" run-file
|
"../parser-combinators/lazy.factor" run-file
|
||||||
"../parser-combinators/parser-combinators.factor" run-file
|
"../parser-combinators/parser-combinators.factor" run-file
|
||||||
"cpu.factor" run-file
|
"cpu-8080.factor" run-file
|
||||||
! "tests.factor" run-file
|
"space-invaders.factor" run-file
|
||||||
|
|
||||||
|
"cpu-8080" words [ try-compile ] each
|
||||||
|
|
||||||
|
"Use 'run' in the 'space-invaders' vocabulary to start." print
|
||||||
|
|
@ -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
|
to produce an emulator, disassembler and assembler for the 8080
|
||||||
processor.
|
processor.
|
||||||
|
|
||||||
Running 'load.factor' will load the CPU emulation routines and
|
Running 'load.factor' will load all necessary files to run the game.
|
||||||
supporting code. Run 'gui.factor' to get the SDL based GUI code.
|
|
||||||
|
|
||||||
If you are in the space-invaders directory, and have the ROM as a file
|
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:
|
'invaders.rom' in that same directory, the following starts the GUI:
|
||||||
|
|
||||||
"load.factor" run-file
|
"load.factor" run-file
|
||||||
"gui.factor" run-file
|
USE: space-invaders
|
||||||
USE: cpu-8080
|
run
|
||||||
display
|
|
||||||
|
|
||||||
This will run the emulator in interpreted mode. To compile the Factor
|
'Backspace' inserts a coin, '1' is the one player button and '2' is
|
||||||
code do the following:
|
the two play button. The left and right arrow keys move and the left
|
||||||
|
control key fires.
|
||||||
"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.
|
|
||||||
|
|
||||||
If the ROM file you have is split into seperate files, you will need
|
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
|
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
|
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
|
For more information, contact the author, Chris Double, at
|
||||||
chris.double@double.co.nz or from my weblog http://radio.weblogs.com/0102385
|
chris.double@double.co.nz or from my weblog
|
||||||
|
http://radio.weblogs.com/0102385
|
||||||
|
|
|
||||||
|
|
@ -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 )
|
||||||
|
[ <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 [
|
||||||
|
<space-invaders> "invaders.rom" over load-rom
|
||||||
|
<event> event-loop
|
||||||
|
SDL_Quit
|
||||||
|
] with-screen ;
|
||||||
|
|
||||||
Loading…
Reference in New Issue