Merge branch 'invaders' of git://double.co.nz/git/factor
commit
7f3efb3b5d
|
@ -502,10 +502,10 @@ TUPLE: action-parser p1 quot ;
|
||||||
|
|
||||||
: check-action ( result quot -- result )
|
: check-action ( result quot -- result )
|
||||||
over [
|
over [
|
||||||
over ast>> swap call >>ast
|
over ast>> swap call( ast -- ast ) >>ast
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ; inline
|
] if ;
|
||||||
|
|
||||||
M: action-parser (compile) ( peg -- quot )
|
M: action-parser (compile) ( peg -- quot )
|
||||||
[ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
|
[ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: help.syntax help.markup cpu.8080.emulator ;
|
USING: help.syntax help.markup cpu.8080.emulator ;
|
||||||
IN: balloon-bomber
|
IN: balloon-bomber
|
||||||
|
|
||||||
HELP: run
|
HELP: run-balloon
|
||||||
{ $description
|
{ $description
|
||||||
"Run the Balloon Bomber emulator in a new window." $nl
|
"Run the Balloon Bomber emulator in a new window." $nl
|
||||||
{ $link rom-root } " must be set to the directory containing the "
|
{ $link rom-root } " must be set to the directory containing the "
|
||||||
|
@ -25,7 +25,7 @@ ARTICLE: { "balloon-bomber" "balloon-bomber" } "Balloon Bomber Emulator"
|
||||||
"ballbomb/tn05-1"
|
"ballbomb/tn05-1"
|
||||||
}
|
}
|
||||||
"These are the same ROM files as used by MAME. To run the game use the "
|
"These are the same ROM files as used by MAME. To run the game use the "
|
||||||
{ $link run } " word." $nl
|
{ $link run-balloon } " word." $nl
|
||||||
"Keys:"
|
"Keys:"
|
||||||
{ $table
|
{ $table
|
||||||
{ "Backspace" "Insert Coin" }
|
{ "Backspace" "Insert Coin" }
|
|
@ -3,21 +3,28 @@
|
||||||
!
|
!
|
||||||
! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb
|
! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb
|
||||||
!
|
!
|
||||||
USING: kernel space-invaders cpu.8080 ui ;
|
USING:
|
||||||
|
cpu.8080
|
||||||
|
kernel
|
||||||
|
space-invaders
|
||||||
|
ui
|
||||||
|
;
|
||||||
IN: balloon-bomber
|
IN: balloon-bomber
|
||||||
|
|
||||||
TUPLE: balloon-bomber ;
|
TUPLE: balloon-bomber < space-invaders ;
|
||||||
|
|
||||||
: <balloon-bomber> ( -- cpu )
|
: <balloon-bomber> ( -- cpu )
|
||||||
<space-invaders> balloon-bomber construct-delegate ;
|
balloon-bomber new cpu-init ;
|
||||||
|
|
||||||
: run ( -- )
|
CONSTANT: rom-info {
|
||||||
"Balloon Bomber" <balloon-bomber> {
|
|
||||||
{ HEX: 0000 "ballbomb/tn01" }
|
{ HEX: 0000 "ballbomb/tn01" }
|
||||||
{ HEX: 0800 "ballbomb/tn02" }
|
{ HEX: 0800 "ballbomb/tn02" }
|
||||||
{ HEX: 1000 "ballbomb/tn03" }
|
{ HEX: 1000 "ballbomb/tn03" }
|
||||||
{ HEX: 1800 "ballbomb/tn04" }
|
{ HEX: 1800 "ballbomb/tn04" }
|
||||||
{ HEX: 4000 "ballbomb/tn05-1" }
|
{ HEX: 4000 "ballbomb/tn05-1" }
|
||||||
} [ (run) ] with-ui ;
|
}
|
||||||
|
|
||||||
MAIN: run
|
: run-balloon ( -- )
|
||||||
|
[ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: run-balloon
|
|
@ -1,10 +1,32 @@
|
||||||
! Copyright (C) 2006 Chris Double.
|
! Copyright (C) 2006 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
!
|
!
|
||||||
USING: accessors kernel math sequences words arrays io io.files
|
USING:
|
||||||
math.parser assocs quotations parser lexer
|
accessors
|
||||||
peg peg.ebnf peg.parsers tools.time io.encodings.binary sequences.deep
|
arrays
|
||||||
symbols combinators fry namespaces ;
|
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
|
||||||
|
syntax
|
||||||
|
words
|
||||||
|
;
|
||||||
IN: cpu.8080.emulator
|
IN: cpu.8080.emulator
|
||||||
|
|
||||||
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
|
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
|
||||||
|
@ -27,93 +49,93 @@ M: cpu write-port ( value port cpu -- )
|
||||||
#! an 8-bit value.
|
#! an 8-bit value.
|
||||||
3drop ;
|
3drop ;
|
||||||
|
|
||||||
: carry-flag HEX: 01 ; inline
|
CONSTANT: carry-flag HEX: 01
|
||||||
: parity-flag HEX: 04 ; inline
|
CONSTANT: parity-flag HEX: 04
|
||||||
: half-carry-flag HEX: 10 ; inline
|
CONSTANT: half-carry-flag HEX: 10
|
||||||
: interrupt-flag HEX: 20 ; inline
|
CONSTANT: interrupt-flag HEX: 20
|
||||||
: zero-flag HEX: 40 ; inline
|
CONSTANT: zero-flag HEX: 40
|
||||||
: sign-flag HEX: 80 ; inline
|
CONSTANT: sign-flag HEX: 80
|
||||||
|
|
||||||
: >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 ;
|
||||||
|
|
||||||
: cpu-af ( cpu -- word )
|
: af>> ( cpu -- word )
|
||||||
#! Return the 16-bit pseudo register AF.
|
#! Return the 16-bit pseudo register AF.
|
||||||
[ cpu-a 8 shift ] keep cpu-f bitor ;
|
[ a>> 8 shift ] keep f>> bitor ;
|
||||||
|
|
||||||
: set-cpu-af ( value cpu -- )
|
: (>>af) ( value cpu -- )
|
||||||
#! Set the value of the 16-bit pseudo register AF
|
#! Set the value of the 16-bit pseudo register AF
|
||||||
>r >word< r> tuck set-cpu-f set-cpu-a ;
|
[ >word< ] dip swap >>f swap >>a drop ;
|
||||||
|
|
||||||
: cpu-bc ( cpu -- word )
|
: bc>> ( cpu -- word )
|
||||||
#! Return the 16-bit pseudo register BC.
|
#! Return the 16-bit pseudo register BC.
|
||||||
[ cpu-b 8 shift ] keep cpu-c bitor ;
|
[ b>> 8 shift ] keep c>> bitor ;
|
||||||
|
|
||||||
: set-cpu-bc ( value cpu -- )
|
: (>>bc) ( value cpu -- )
|
||||||
#! Set the value of the 16-bit pseudo register BC
|
#! Set the value of the 16-bit pseudo register BC
|
||||||
>r >word< r> tuck set-cpu-c set-cpu-b ;
|
[ >word< ] dip swap >>c swap >>b drop ;
|
||||||
|
|
||||||
: cpu-de ( cpu -- word )
|
: de>> ( cpu -- word )
|
||||||
#! Return the 16-bit pseudo register DE.
|
#! Return the 16-bit pseudo register DE.
|
||||||
[ cpu-d 8 shift ] keep cpu-e bitor ;
|
[ d>> 8 shift ] keep e>> bitor ;
|
||||||
|
|
||||||
: set-cpu-de ( value cpu -- )
|
: (>>de) ( value cpu -- )
|
||||||
#! Set the value of the 16-bit pseudo register DE
|
#! Set the value of the 16-bit pseudo register DE
|
||||||
>r >word< r> tuck set-cpu-e set-cpu-d ;
|
[ >word< ] dip swap >>e swap >>d drop ;
|
||||||
|
|
||||||
: cpu-hl ( cpu -- word )
|
: hl>> ( cpu -- word )
|
||||||
#! Return the 16-bit pseudo register HL.
|
#! Return the 16-bit pseudo register HL.
|
||||||
[ cpu-h 8 shift ] keep cpu-l bitor ;
|
[ h>> 8 shift ] keep l>> bitor ;
|
||||||
|
|
||||||
: set-cpu-hl ( value cpu -- )
|
: (>>hl) ( value cpu -- )
|
||||||
#! Set the value of the 16-bit pseudo register HL
|
#! Set the value of the 16-bit pseudo register HL
|
||||||
>r >word< r> tuck set-cpu-l set-cpu-h ;
|
[ >word< ] dip swap >>l swap >>h drop ;
|
||||||
|
|
||||||
: flag-set? ( flag cpu -- bool )
|
: flag-set? ( flag cpu -- bool )
|
||||||
cpu-f bitand 0 = not ;
|
f>> bitand 0 = not ;
|
||||||
|
|
||||||
: flag-clear? ( flag cpu -- bool )
|
: flag-clear? ( flag cpu -- bool )
|
||||||
cpu-f bitand 0 = ;
|
f>> bitand 0 = ;
|
||||||
|
|
||||||
: flag-nz? ( cpu -- bool )
|
: flag-nz? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f zero-flag bitand 0 = ;
|
f>> zero-flag bitand 0 = ;
|
||||||
|
|
||||||
: flag-z? ( cpu -- bool )
|
: flag-z? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f zero-flag bitand 0 = not ;
|
f>> zero-flag bitand 0 = not ;
|
||||||
|
|
||||||
: flag-nc? ( cpu -- bool )
|
: flag-nc? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f carry-flag bitand 0 = ;
|
f>> carry-flag bitand 0 = ;
|
||||||
|
|
||||||
: flag-c? ( cpu -- bool )
|
: flag-c? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f carry-flag bitand 0 = not ;
|
f>> carry-flag bitand 0 = not ;
|
||||||
|
|
||||||
: flag-po? ( cpu -- bool )
|
: flag-po? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f parity-flag bitand 0 = ;
|
f>> parity-flag bitand 0 = ;
|
||||||
|
|
||||||
: flag-pe? ( cpu -- bool )
|
: flag-pe? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f parity-flag bitand 0 = not ;
|
f>> parity-flag bitand 0 = not ;
|
||||||
|
|
||||||
: flag-p? ( cpu -- bool )
|
: flag-p? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f sign-flag bitand 0 = ;
|
f>> sign-flag bitand 0 = ;
|
||||||
|
|
||||||
: flag-m? ( cpu -- bool )
|
: flag-m? ( cpu -- bool )
|
||||||
#! Test flag status
|
#! Test flag status
|
||||||
cpu-f sign-flag bitand 0 = not ;
|
f>> sign-flag bitand 0 = not ;
|
||||||
|
|
||||||
: read-byte ( addr cpu -- byte )
|
: read-byte ( addr cpu -- byte )
|
||||||
#! Read one byte from memory at the specified address.
|
#! Read one byte 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.
|
||||||
over HEX: FFFF <= [
|
over HEX: FFFF <= [
|
||||||
cpu-ram nth
|
ram>> nth
|
||||||
] [
|
] [
|
||||||
2drop HEX: FF
|
2drop HEX: FF
|
||||||
] if ;
|
] if ;
|
||||||
|
@ -122,21 +144,21 @@ M: cpu write-port ( value port cpu -- )
|
||||||
#! 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 ;
|
[ read-byte ] 2keep [ 1 + ] dip 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.
|
||||||
[ cpu-pc ] keep
|
[ pc>> ] keep
|
||||||
[ read-byte ] keep
|
[ read-byte ] keep
|
||||||
[ cpu-pc 1 + ] keep
|
[ pc>> 1 + ] keep
|
||||||
set-cpu-pc ;
|
(>>pc) ;
|
||||||
|
|
||||||
: next-word ( cpu -- word )
|
: next-word ( cpu -- word )
|
||||||
#! Return the value of the word at PC, and increment PC.
|
#! Return the value of the word at PC, and increment PC.
|
||||||
[ cpu-pc ] keep
|
[ pc>> ] keep
|
||||||
[ read-word ] keep
|
[ read-word ] keep
|
||||||
[ cpu-pc 2 + ] keep
|
[ pc>> 2 + ] keep
|
||||||
set-cpu-pc ;
|
(>>pc) ;
|
||||||
|
|
||||||
|
|
||||||
: write-byte ( value addr cpu -- )
|
: write-byte ( value addr cpu -- )
|
||||||
|
@ -144,54 +166,54 @@ M: cpu write-port ( value port cpu -- )
|
||||||
over dup HEX: 2000 < swap HEX: FFFF > or [
|
over dup HEX: 2000 < swap HEX: FFFF > or [
|
||||||
3drop
|
3drop
|
||||||
] [
|
] [
|
||||||
3dup cpu-ram set-nth
|
3dup ram>> set-nth
|
||||||
update-video
|
update-video
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
||||||
: 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.
|
||||||
>r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
|
[ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ;
|
||||||
|
|
||||||
: 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
|
[ a>> swap call bitand ] keep (>>a) ; inline
|
||||||
|
|
||||||
: cpu-a-bitor ( quot cpu -- )
|
: cpu-a-bitor ( quot cpu -- )
|
||||||
#! A |= quot call
|
#! A |= quot call
|
||||||
[ cpu-a swap call bitor ] keep set-cpu-a ; inline
|
[ a>> swap call bitor ] keep (>>a) ; inline
|
||||||
|
|
||||||
: cpu-a-bitxor ( quot cpu -- )
|
: cpu-a-bitxor ( quot cpu -- )
|
||||||
#! A ^= quot call
|
#! A ^= quot call
|
||||||
[ cpu-a swap call bitxor ] keep set-cpu-a ; inline
|
[ a>> swap call bitxor ] keep (>>a) ; inline
|
||||||
|
|
||||||
: cpu-a-bitxor= ( value cpu -- )
|
: cpu-a-bitxor= ( value cpu -- )
|
||||||
#! cpu-a ^= value
|
#! cpu-a ^= value
|
||||||
[ cpu-a bitxor ] keep set-cpu-a ;
|
[ a>> bitxor ] keep (>>a) ;
|
||||||
|
|
||||||
: cpu-f-bitand ( quot cpu -- )
|
: cpu-f-bitand ( quot cpu -- )
|
||||||
#! F &= quot call
|
#! F &= quot call
|
||||||
[ cpu-f swap call bitand ] keep set-cpu-f ; inline
|
[ f>> swap call bitand ] keep (>>f) ; inline
|
||||||
|
|
||||||
: cpu-f-bitor ( quot cpu -- )
|
: cpu-f-bitor ( quot cpu -- )
|
||||||
#! F |= quot call
|
#! F |= quot call
|
||||||
[ cpu-f swap call bitor ] keep set-cpu-f ; inline
|
[ f>> swap call bitor ] keep (>>f) ; inline
|
||||||
|
|
||||||
: cpu-f-bitxor ( quot cpu -- )
|
: cpu-f-bitxor ( quot cpu -- )
|
||||||
#! F |= quot call
|
#! F |= quot call
|
||||||
[ cpu-f swap call bitxor ] keep set-cpu-f ; inline
|
[ f>> swap call bitxor ] keep (>>f) ; inline
|
||||||
|
|
||||||
: cpu-f-bitor= ( value cpu -- )
|
: cpu-f-bitor= ( value cpu -- )
|
||||||
#! cpu-f |= value
|
#! cpu-f |= value
|
||||||
[ cpu-f bitor ] keep set-cpu-f ;
|
[ f>> bitor ] keep (>>f) ;
|
||||||
|
|
||||||
: cpu-f-bitand= ( value cpu -- )
|
: cpu-f-bitand= ( value cpu -- )
|
||||||
#! cpu-f &= value
|
#! cpu-f &= value
|
||||||
[ cpu-f bitand ] keep set-cpu-f ;
|
[ f>> bitand ] keep (>>f) ;
|
||||||
|
|
||||||
: cpu-f-bitxor= ( value cpu -- )
|
: cpu-f-bitxor= ( value cpu -- )
|
||||||
#! cpu-f ^= value
|
#! cpu-f ^= value
|
||||||
[ cpu-f bitxor ] keep set-cpu-f ;
|
[ f>> bitxor ] keep (>>f) ;
|
||||||
|
|
||||||
: set-flag ( cpu flag -- )
|
: set-flag ( cpu flag -- )
|
||||||
swap cpu-f-bitor= ;
|
swap cpu-f-bitor= ;
|
||||||
|
@ -228,7 +250,7 @@ M: cpu write-port ( value port cpu -- )
|
||||||
#! The 'original' is the original value of the register being changed.
|
#! The 'original' is the original value of the register being changed.
|
||||||
#! 'change-by' is the amount it is being added or decremented by.
|
#! 'change-by' is the amount it is being added or decremented by.
|
||||||
#! 'result' is the result of that change.
|
#! 'result' is the result of that change.
|
||||||
>r bitxor bitxor HEX: 10 bitand 0 = not r>
|
[ bitxor bitxor HEX: 10 bitand 0 = not ] dip
|
||||||
swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
|
swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
|
||||||
|
|
||||||
: update-flags ( result cpu -- )
|
: update-flags ( result cpu -- )
|
||||||
|
@ -244,18 +266,18 @@ M: cpu write-port ( value port cpu -- )
|
||||||
|
|
||||||
: add-byte ( lhs rhs cpu -- result )
|
: add-byte ( lhs rhs cpu -- result )
|
||||||
#! Add rhs to lhs
|
#! Add rhs to lhs
|
||||||
>r 2dup + r> ! lhs rhs result cpu
|
[ 2dup + ] dip
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
|
||||||
: add-carry ( change-by result cpu -- change-by result )
|
: add-carry ( change-by result cpu -- change-by result )
|
||||||
#! Add the effect of the carry flag to the result
|
#! Add the effect of the carry flag to the result
|
||||||
flag-c? [ 1 + >r 1 + r> ] when ;
|
flag-c? [ 1 + [ 1 + ] dip ] when ;
|
||||||
|
|
||||||
: add-byte-with-carry ( lhs rhs cpu -- result )
|
: add-byte-with-carry ( lhs rhs cpu -- result )
|
||||||
#! Add rhs to lhs plus carry.
|
#! Add rhs to lhs plus carry.
|
||||||
>r 2dup + r> ! lhs rhs result cpu
|
[ 2dup + ] dip
|
||||||
[ add-carry ] keep
|
[ add-carry ] keep
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
|
@ -263,18 +285,18 @@ M: cpu write-port ( value port cpu -- )
|
||||||
|
|
||||||
: sub-carry ( change-by result cpu -- change-by result )
|
: sub-carry ( change-by result cpu -- change-by result )
|
||||||
#! Subtract the effect of the carry flag from the result
|
#! Subtract the effect of the carry flag from the result
|
||||||
flag-c? [ 1 - >r 1 - r> ] when ;
|
flag-c? [ 1 - [ 1 - ] dip ] when ;
|
||||||
|
|
||||||
: sub-byte ( lhs rhs cpu -- result )
|
: sub-byte ( lhs rhs cpu -- result )
|
||||||
#! Subtract rhs from lhs
|
#! Subtract rhs from lhs
|
||||||
>r 2dup - r>
|
[ 2dup - ] dip
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
|
||||||
: sub-byte-with-carry ( lhs rhs cpu -- result )
|
: sub-byte-with-carry ( lhs rhs cpu -- result )
|
||||||
#! Subtract rhs from lhs and take carry into account
|
#! Subtract rhs from lhs and take carry into account
|
||||||
>r 2dup - r>
|
[ 2dup - ] dip
|
||||||
[ sub-carry ] keep
|
[ sub-carry ] keep
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
|
@ -283,7 +305,7 @@ M: cpu write-port ( value port cpu -- )
|
||||||
: inc-byte ( byte cpu -- result )
|
: inc-byte ( byte cpu -- result )
|
||||||
#! Increment byte by one. Note that carry flag is not affected
|
#! Increment byte by one. Note that carry flag is not affected
|
||||||
#! by this operation.
|
#! by this operation.
|
||||||
>r 1 2dup + r> ! lhs rhs result cpu
|
[ 1 2dup + ] dip
|
||||||
[ update-flags-no-carry ] 2keep
|
[ update-flags-no-carry ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
@ -291,7 +313,7 @@ M: cpu write-port ( value port cpu -- )
|
||||||
: dec-byte ( byte cpu -- result )
|
: dec-byte ( byte cpu -- result )
|
||||||
#! Decrement byte by one. Note that carry flag is not affected
|
#! Decrement byte by one. Note that carry flag is not affected
|
||||||
#! by this operation.
|
#! by this operation.
|
||||||
>r 1 2dup - r> ! lhs rhs result cpu
|
[ 1 2dup - ] dip
|
||||||
[ update-flags-no-carry ] 2keep
|
[ update-flags-no-carry ] 2keep
|
||||||
[ update-half-carry-flag ] 2keep
|
[ update-half-carry-flag ] 2keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
@ -307,47 +329,45 @@ M: cpu write-port ( value port cpu -- )
|
||||||
: add-word ( lhs rhs cpu -- result )
|
: add-word ( lhs rhs cpu -- result )
|
||||||
#! Add rhs to lhs. Note that only the carry flag is modified
|
#! 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.
|
#! and only if there is a carry out of the double precision add.
|
||||||
>r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
|
[ + ] dip over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
|
||||||
|
|
||||||
: bit3or ( lhs rhs -- 0|1 )
|
: bit3or ( lhs rhs -- 0|1 )
|
||||||
#! bitor bit 3 of the two numbers on the stack
|
#! bitor bit 3 of the two numbers on the stack
|
||||||
BIN: 00001000 bitand -3 shift >r
|
BIN: 00001000 bitand -3 shift [
|
||||||
BIN: 00001000 bitand -3 shift r>
|
BIN: 00001000 bitand -3 shift
|
||||||
|
] dip
|
||||||
bitor ;
|
bitor ;
|
||||||
|
|
||||||
: and-byte ( lhs rhs cpu -- result )
|
: and-byte ( lhs rhs cpu -- result )
|
||||||
#! Logically and rhs to lhs. The carry flag is cleared and
|
#! 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.
|
#! the half carry is set to the ORing of bits 3 of the operands.
|
||||||
[ drop bit3or ] 3keep ! bit3or lhs rhs cpu
|
[ drop bit3or ] 3keep ! bit3or lhs rhs cpu
|
||||||
>r bitand r> [ update-flags ] 2keep
|
[ bitand ] dip [ update-flags ] 2keep
|
||||||
[ carry-flag clear-flag ] keep
|
[ carry-flag clear-flag ] keep
|
||||||
rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
|
rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
|
||||||
HEX: FF bitand ;
|
HEX: FF bitand ;
|
||||||
|
|
||||||
: xor-byte ( lhs rhs cpu -- result )
|
: xor-byte ( lhs rhs cpu -- result )
|
||||||
#! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
|
#! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
|
||||||
>r bitxor r> [ update-flags ] 2keep
|
[ bitxor ] dip [ update-flags ] 2keep
|
||||||
[ half-carry-flag carry-flag bitor clear-flag ] keep
|
[ half-carry-flag carry-flag bitor clear-flag ] keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
|
||||||
: or-byte ( lhs rhs cpu -- result )
|
: or-byte ( lhs rhs cpu -- result )
|
||||||
#! Logically or rhs to lhs. The carry and half-carry flags are cleared.
|
#! Logically or rhs to lhs. The carry and half-carry flags are cleared.
|
||||||
>r bitor r> [ update-flags ] 2keep
|
[ bitor ] dip [ update-flags ] 2keep
|
||||||
[ half-carry-flag carry-flag bitor clear-flag ] keep
|
[ half-carry-flag carry-flag bitor clear-flag ] keep
|
||||||
drop HEX: FF bitand ;
|
drop HEX: FF bitand ;
|
||||||
|
|
||||||
: flags ( seq -- seq )
|
|
||||||
[ 0 [ execute bitor ] reduce ] map ;
|
|
||||||
|
|
||||||
: decrement-sp ( n cpu -- )
|
: decrement-sp ( n cpu -- )
|
||||||
#! Decrement the stackpointer by n.
|
#! Decrement the stackpointer by n.
|
||||||
[ cpu-sp ] keep
|
[ sp>> ] keep
|
||||||
>r swap - r> set-cpu-sp ;
|
[ swap - ] dip (>>sp) ;
|
||||||
|
|
||||||
: save-pc ( cpu -- )
|
: save-pc ( cpu -- )
|
||||||
#! Save the value of the PC on the stack.
|
#! Save the value of the PC on the stack.
|
||||||
[ cpu-pc ] keep ! pc cpu
|
[ pc>> ] keep ! pc cpu
|
||||||
[ cpu-sp ] keep ! pc sp cpu
|
[ sp>> ] keep ! pc sp cpu
|
||||||
write-word ;
|
write-word ;
|
||||||
|
|
||||||
: push-pc ( cpu -- )
|
: push-pc ( cpu -- )
|
||||||
|
@ -357,46 +377,49 @@ M: cpu write-port ( value port cpu -- )
|
||||||
|
|
||||||
: pop-pc ( cpu -- pc )
|
: pop-pc ( cpu -- pc )
|
||||||
#! Pop the value of the PC off the stack.
|
#! Pop the value of the PC off the stack.
|
||||||
[ cpu-sp ] keep
|
[ sp>> ] keep
|
||||||
[ read-word ] keep
|
[ read-word ] keep
|
||||||
-2 swap decrement-sp ;
|
-2 swap decrement-sp ;
|
||||||
|
|
||||||
: push-sp ( value cpu -- )
|
: push-sp ( value cpu -- )
|
||||||
[ 2 swap decrement-sp ] keep
|
[ 2 swap decrement-sp ] keep
|
||||||
[ cpu-sp ] keep
|
[ sp>> ] keep
|
||||||
write-word ;
|
write-word ;
|
||||||
|
|
||||||
: pop-sp ( cpu -- value )
|
: pop-sp ( cpu -- value )
|
||||||
[ cpu-sp ] keep
|
[ sp>> ] keep
|
||||||
[ read-word ] keep
|
[ read-word ] keep
|
||||||
-2 swap decrement-sp ;
|
-2 swap decrement-sp ;
|
||||||
|
|
||||||
: call-sub ( addr cpu -- )
|
: call-sub ( addr cpu -- )
|
||||||
#! Call the address as a subroutine.
|
#! Call the address as a subroutine.
|
||||||
dup push-pc
|
dup push-pc
|
||||||
>r HEX: FFFF bitand r> set-cpu-pc ;
|
[ HEX: FFFF bitand ] dip (>>pc) ;
|
||||||
|
|
||||||
: ret-from-sub ( cpu -- )
|
: ret-from-sub ( cpu -- )
|
||||||
[ pop-pc ] keep set-cpu-pc ;
|
[ pop-pc ] keep (>>pc) ;
|
||||||
|
|
||||||
: 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
|
||||||
dup cpu-f interrupt-flag bitand 0 = not [
|
dup f>> interrupt-flag bitand 0 = not [
|
||||||
dup push-pc
|
dup push-pc
|
||||||
set-cpu-pc
|
(>>pc)
|
||||||
] [
|
] [
|
||||||
2drop
|
2drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: inc-cycles ( n cpu -- )
|
: inc-cycles ( n cpu -- )
|
||||||
#! Increment the number of cpu cycles
|
#! Increment the number of cpu cycles
|
||||||
[ cpu-cycles + ] keep set-cpu-cycles ;
|
[ cycles>> + ] keep (>>cycles) ;
|
||||||
|
|
||||||
: instruction-cycles ( -- vector )
|
: 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.
|
||||||
<< 256 f <array> parsed >> ;
|
\ instruction-cycles get-global [
|
||||||
|
256 f <array> \ instruction-cycles set-global
|
||||||
|
] unless
|
||||||
|
\ instruction-cycles get-global ;
|
||||||
|
|
||||||
: not-implemented ( <cpu> -- )
|
: not-implemented ( <cpu> -- )
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -404,33 +427,37 @@ M: cpu write-port ( value port cpu -- )
|
||||||
: instructions ( -- vector )
|
: 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.
|
||||||
<< 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
|
\ instructions get-global [
|
||||||
|
256 [ not-implemented ] <array> \ instructions set-global
|
||||||
|
] unless
|
||||||
|
\ instructions get-global ;
|
||||||
|
|
||||||
: set-instruction ( quot n -- )
|
: set-instruction ( quot n -- )
|
||||||
tuck >r 2array r> instructions set-nth ;
|
instructions set-nth ;
|
||||||
|
|
||||||
M: cpu 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 >>b
|
||||||
[ 0 swap set-cpu-c ] keep
|
0 >>c
|
||||||
[ 0 swap set-cpu-d ] keep
|
0 >>d
|
||||||
[ 0 swap set-cpu-e ] keep
|
0 >>e
|
||||||
[ 0 swap set-cpu-h ] keep
|
0 >>h
|
||||||
[ 0 swap set-cpu-l ] keep
|
0 >>l
|
||||||
[ 0 swap set-cpu-a ] keep
|
0 >>a
|
||||||
[ 0 swap set-cpu-f ] keep
|
0 >>f
|
||||||
[ 0 swap set-cpu-pc ] keep
|
0 >>pc
|
||||||
[ HEX: F000 swap set-cpu-sp ] keep
|
HEX: F000 >>sp
|
||||||
[ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
|
HEX: FFFF 0 <array> >>ram
|
||||||
[ f swap set-cpu-halted? ] keep
|
f >>halted?
|
||||||
[ HEX: 10 swap set-cpu-last-interrupt ] keep
|
HEX: 10 >>last-interrupt
|
||||||
0 swap set-cpu-cycles ;
|
0 >>cycles
|
||||||
|
drop ;
|
||||||
|
|
||||||
: <cpu> ( -- cpu ) cpu new dup reset ;
|
: <cpu> ( -- cpu ) cpu new dup reset ;
|
||||||
|
|
||||||
: (load-rom) ( n ram -- )
|
: (load-rom) ( n ram -- )
|
||||||
read1 [ ! n ram ch
|
read1 [ ! n ram ch
|
||||||
-rot [ set-nth ] 2keep >r 1 + r> (load-rom)
|
-rot [ set-nth ] 2keep [ 1 + ] dip (load-rom)
|
||||||
] [
|
] [
|
||||||
2drop
|
2drop
|
||||||
] if* ;
|
] if* ;
|
||||||
|
@ -440,7 +467,7 @@ M: cpu reset ( cpu -- )
|
||||||
: load-rom ( filename cpu -- )
|
: load-rom ( filename cpu -- )
|
||||||
#! Load the contents of the file into ROM.
|
#! Load the contents of the file into ROM.
|
||||||
#! (address 0x0000-0x1FFF).
|
#! (address 0x0000-0x1FFF).
|
||||||
cpu-ram swap binary [
|
ram>> swap binary [
|
||||||
0 swap (load-rom)
|
0 swap (load-rom)
|
||||||
] with-file-reader ;
|
] with-file-reader ;
|
||||||
|
|
||||||
|
@ -455,7 +482,7 @@ SYMBOL: rom-root
|
||||||
#! file will be loaded at the specified address. This
|
#! file will be loaded at the specified address. This
|
||||||
#! file path shoul dbe relative to the '/roms' resource path.
|
#! file path shoul dbe relative to the '/roms' resource path.
|
||||||
rom-dir [
|
rom-dir [
|
||||||
cpu-ram [
|
ram>> [
|
||||||
swap first2 rom-dir prepend-path binary [
|
swap first2 rom-dir prepend-path binary [
|
||||||
swap (load-rom)
|
swap (load-rom)
|
||||||
] with-file-reader
|
] with-file-reader
|
||||||
|
@ -469,8 +496,8 @@ SYMBOL: rom-root
|
||||||
: read-instruction ( cpu -- word )
|
: read-instruction ( cpu -- word )
|
||||||
#! Read the next instruction from the cpu's program
|
#! Read the next instruction from the cpu's program
|
||||||
#! counter, and increment the program counter.
|
#! counter, and increment the program counter.
|
||||||
[ cpu-pc ] keep ! pc cpu
|
[ pc>> ] keep ! pc cpu
|
||||||
[ over 1 + swap set-cpu-pc ] keep
|
[ over 1 + swap (>>pc) ] keep
|
||||||
read-byte ;
|
read-byte ;
|
||||||
|
|
||||||
: get-cycles ( n -- opcode )
|
: get-cycles ( n -- opcode )
|
||||||
|
@ -484,50 +511,50 @@ SYMBOL: rom-root
|
||||||
|
|
||||||
: process-interrupts ( cpu -- )
|
: process-interrupts ( cpu -- )
|
||||||
#! Process any hardware interrupts
|
#! Process any hardware interrupts
|
||||||
[ cpu-cycles ] keep
|
[ cycles>> ] keep
|
||||||
over 16667 < [
|
over 16667 < [
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
[ >r 16667 - r> set-cpu-cycles ] keep
|
[ [ 16667 - ] dip (>>cycles) ] keep
|
||||||
dup cpu-last-interrupt HEX: 10 = [
|
dup last-interrupt>> HEX: 10 = [
|
||||||
HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
|
HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt
|
||||||
] [
|
] [
|
||||||
HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
|
HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt
|
||||||
] if
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: peek-instruction ( cpu -- word )
|
: peek-instruction ( cpu -- word )
|
||||||
#! Return the next instruction from the cpu's program
|
#! Return the next instruction from the cpu's program
|
||||||
#! counter, but don't increment the counter.
|
#! counter, but don't increment the counter.
|
||||||
[ cpu-pc ] keep read-byte instructions nth first ;
|
[ pc>> ] keep read-byte instructions nth first ;
|
||||||
|
|
||||||
: cpu. ( cpu -- )
|
: cpu. ( cpu -- )
|
||||||
[ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
|
[ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep
|
||||||
[ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
|
[ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep
|
||||||
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
|
[ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
|
||||||
[ " " write peek-instruction name>> write " " write ] keep
|
[ " " write peek-instruction name>> write " " write ] keep
|
||||||
nl drop ;
|
nl drop ;
|
||||||
|
|
||||||
: cpu*. ( cpu -- )
|
: cpu*. ( cpu -- )
|
||||||
[ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
|
[ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep
|
||||||
[ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
|
[ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep
|
||||||
[ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
|
[ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep
|
||||||
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
|
[ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
|
||||||
nl drop ;
|
nl drop ;
|
||||||
|
|
||||||
: register-lookup ( string -- vector )
|
: register-lookup ( string -- vector )
|
||||||
|
@ -535,18 +562,18 @@ SYMBOL: rom-root
|
||||||
#! where the 1st item is the getter and the 2nd is the setter
|
#! where the 1st item is the getter and the 2nd is the setter
|
||||||
#! for that register.
|
#! for that register.
|
||||||
H{
|
H{
|
||||||
{ "A" { cpu-a set-cpu-a } }
|
{ "A" { a>> (>>a) } }
|
||||||
{ "B" { cpu-b set-cpu-b } }
|
{ "B" { b>> (>>b) } }
|
||||||
{ "C" { cpu-c set-cpu-c } }
|
{ "C" { c>> (>>c) } }
|
||||||
{ "D" { cpu-d set-cpu-d } }
|
{ "D" { d>> (>>d) } }
|
||||||
{ "E" { cpu-e set-cpu-e } }
|
{ "E" { e>> (>>e) } }
|
||||||
{ "H" { cpu-h set-cpu-h } }
|
{ "H" { h>> (>>h) } }
|
||||||
{ "L" { cpu-l set-cpu-l } }
|
{ "L" { l>> (>>l) } }
|
||||||
{ "AF" { cpu-af set-cpu-af } }
|
{ "AF" { af>> (>>af) } }
|
||||||
{ "BC" { cpu-bc set-cpu-bc } }
|
{ "BC" { bc>> (>>bc) } }
|
||||||
{ "DE" { cpu-de set-cpu-de } }
|
{ "DE" { de>> (>>de) } }
|
||||||
{ "HL" { cpu-hl set-cpu-hl } }
|
{ "HL" { hl>> (>>hl) } }
|
||||||
{ "SP" { cpu-sp set-cpu-sp } }
|
{ "SP" { sp>> (>>sp) } }
|
||||||
} at ;
|
} at ;
|
||||||
|
|
||||||
|
|
||||||
|
@ -579,40 +606,40 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
|
|
||||||
: (emulate-RST) ( n cpu -- )
|
: (emulate-RST) ( n cpu -- )
|
||||||
#! RST nn
|
#! RST nn
|
||||||
[ cpu-sp 2 - dup ] keep ! sp sp cpu
|
[ sp>> 2 - dup ] keep ! sp sp cpu
|
||||||
[ set-cpu-sp ] keep ! sp cpu
|
[ (>>sp) ] keep ! sp cpu
|
||||||
[ cpu-pc ] keep ! sp pc cpu
|
[ pc>> ] keep ! sp pc cpu
|
||||||
swapd [ write-word ] keep ! cpu
|
swapd [ write-word ] keep ! cpu
|
||||||
>r 8 * r> set-cpu-pc ;
|
[ 8 * ] dip (>>pc) ;
|
||||||
|
|
||||||
: (emulate-CALL) ( cpu -- )
|
: (emulate-CALL) ( cpu -- )
|
||||||
#! 205 - CALL nn
|
#! 205 - CALL nn
|
||||||
[ next-word HEX: FFFF bitand ] keep ! addr cpu
|
[ next-word HEX: FFFF bitand ] keep ! addr cpu
|
||||||
[ cpu-sp 2 - dup ] keep ! addr sp sp cpu
|
[ sp>> 2 - dup ] keep ! addr sp sp cpu
|
||||||
[ set-cpu-sp ] keep ! addr sp cpu
|
[ (>>sp) ] keep ! addr sp cpu
|
||||||
[ cpu-pc ] keep ! addr sp pc cpu
|
[ pc>> ] keep ! addr sp pc cpu
|
||||||
swapd [ write-word ] keep ! addr cpu
|
swapd [ write-word ] keep ! addr cpu
|
||||||
set-cpu-pc ;
|
(>>pc) ;
|
||||||
|
|
||||||
: (emulate-RLCA) ( cpu -- )
|
: (emulate-RLCA) ( cpu -- )
|
||||||
#! The content of the accumulator is rotated left
|
#! The content of the accumulator is rotated left
|
||||||
#! one position. The low order bit and the carry flag
|
#! one position. The low order bit and the carry flag
|
||||||
#! are both set to the value shifd out of the high
|
#! are both set to the value shifd out of the high
|
||||||
#! order bit position. Only the carry flag is affected.
|
#! order bit position. Only the carry flag is affected.
|
||||||
[ cpu-a -7 shift ] keep
|
[ a>> -7 shift ] keep
|
||||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||||
[ cpu-a 1 shift HEX: FF bitand ] keep
|
[ a>> 1 shift HEX: FF bitand ] keep
|
||||||
>r bitor r> set-cpu-a ;
|
[ bitor ] dip (>>a) ;
|
||||||
|
|
||||||
: (emulate-RRCA) ( cpu -- )
|
: (emulate-RRCA) ( cpu -- )
|
||||||
#! The content of the accumulator is rotated right
|
#! The content of the accumulator is rotated right
|
||||||
#! one position. The high order bit and the carry flag
|
#! one position. The high order bit and the carry flag
|
||||||
#! are both set to the value shifd out of the low
|
#! are both set to the value shifd out of the low
|
||||||
#! order bit position. Only the carry flag is affected.
|
#! order bit position. Only the carry flag is affected.
|
||||||
[ cpu-a 1 bitand 7 shift ] keep
|
[ a>> 1 bitand 7 shift ] keep
|
||||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||||
[ cpu-a 254 bitand -1 shift ] keep
|
[ a>> 254 bitand -1 shift ] keep
|
||||||
>r bitor r> set-cpu-a ;
|
[ bitor ] dip (>>a) ;
|
||||||
|
|
||||||
: (emulate-RLA) ( cpu -- )
|
: (emulate-RLA) ( cpu -- )
|
||||||
#! The content of the accumulator is rotated left
|
#! The content of the accumulator is rotated left
|
||||||
|
@ -622,9 +649,9 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
#! of the high order bit. Only the carry flag is
|
#! of the high order bit. Only the carry flag is
|
||||||
#! affected.
|
#! affected.
|
||||||
[ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
|
[ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
|
||||||
[ cpu-a 127 bitand 7 shift ] keep
|
[ a>> 127 bitand 7 shift ] keep
|
||||||
dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||||
>r bitor r> set-cpu-a ;
|
[ bitor ] dip (>>a) ;
|
||||||
|
|
||||||
: (emulate-RRA) ( cpu -- )
|
: (emulate-RRA) ( cpu -- )
|
||||||
#! The content of the accumulator is rotated right
|
#! The content of the accumulator is rotated right
|
||||||
|
@ -633,9 +660,9 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
#! set to the value shifd out of the low order bit.
|
#! set to the value shifd out of the low order bit.
|
||||||
#! Only the carry flag is affected.
|
#! Only the carry flag is affected.
|
||||||
[ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
|
[ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
|
||||||
[ cpu-a 254 bitand -1 shift ] keep
|
[ a>> 254 bitand -1 shift ] keep
|
||||||
dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||||
>r bitor r> set-cpu-a ;
|
[ bitor ] dip (>>a) ;
|
||||||
|
|
||||||
: (emulate-CPL) ( cpu -- )
|
: (emulate-CPL) ( cpu -- )
|
||||||
#! The contents of the accumulator are complemented
|
#! The contents of the accumulator are complemented
|
||||||
|
@ -649,18 +676,18 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
#! digits.
|
#! digits.
|
||||||
[
|
[
|
||||||
dup half-carry-flag swap flag-set? swap
|
dup half-carry-flag swap flag-set? swap
|
||||||
cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
|
a>> BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
|
||||||
] keep
|
] keep
|
||||||
[ cpu-a + ] keep
|
[ a>> + ] keep
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
[ swap HEX: FF bitand swap set-cpu-a ] keep
|
[ swap HEX: FF bitand swap (>>a) ] keep
|
||||||
[
|
[
|
||||||
dup carry-flag swap flag-set? swap
|
dup carry-flag swap flag-set? swap
|
||||||
cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
|
a>> -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
|
||||||
] keep
|
] keep
|
||||||
[ cpu-a + ] keep
|
[ a>> + ] keep
|
||||||
[ update-flags ] 2keep
|
[ update-flags ] 2keep
|
||||||
swap HEX: FF bitand swap set-cpu-a ;
|
swap HEX: FF bitand swap (>>a) ;
|
||||||
|
|
||||||
: patterns ( -- hashtable )
|
: patterns ( -- hashtable )
|
||||||
#! table of code quotation patterns for each type of instruction.
|
#! table of code quotation patterns for each type of instruction.
|
||||||
|
@ -676,18 +703,18 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
{ "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
|
{ "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
|
||||||
{ "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
|
{ "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
|
||||||
{ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
|
{ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
|
||||||
{ "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
|
{ "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] }
|
||||||
{ "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
|
{ "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] }
|
||||||
{ "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
|
{ "CP-(RR)" [ [ 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" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep (>>a) ] }
|
||||||
{ "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
|
{ "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep (>>a) ] }
|
||||||
{ "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
|
{ "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep (>>a) ] }
|
||||||
{ "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
|
{ "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep (>>a) ] }
|
||||||
{ "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
|
{ "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep (>>a) ] }
|
||||||
{ "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
|
{ "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep (>>a) ] }
|
||||||
{ "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
|
{ "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep (>>a) ] }
|
||||||
{ "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
|
{ "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep (>>a) ] }
|
||||||
{ "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-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,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,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 ] }
|
{ "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
|
||||||
|
@ -698,9 +725,9 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
{ "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] 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,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 ] }
|
{ "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
|
||||||
{ "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
|
{ "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep (>>a) ] }
|
||||||
{ "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
|
{ "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep (>>a) ] }
|
||||||
{ "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
|
{ "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep (>>a) ] }
|
||||||
{ "CPL" [ (emulate-CPL) ] }
|
{ "CPL" [ (emulate-CPL) ] }
|
||||||
{ "DAA" [ (emulate-DAA) ] }
|
{ "DAA" [ (emulate-DAA) ] }
|
||||||
{ "RLA" [ (emulate-RLA) ] }
|
{ "RLA" [ (emulate-RLA) ] }
|
||||||
|
@ -720,11 +747,11 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
{ "DEC-RR" [ [ $1 ] keep [ dec-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 ] }
|
{ "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 ] }
|
{ "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
|
||||||
{ "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
|
{ "JP-NN" [ [ pc>> ] keep [ read-word ] keep (>>pc) ] }
|
||||||
{ "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
|
{ "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 set-cpu-pc ] }
|
{ "JP-(RR)" [ [ $1 ] keep (>>pc) ] }
|
||||||
{ "CALL-NN" [ (emulate-CALL) ] }
|
{ "CALL-NN" [ (emulate-CALL) ] }
|
||||||
{ "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
|
{ "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,NN" [ [ next-word ] keep $2 ] }
|
||||||
{ "LD-RR,RR" [ [ $3 ] keep $2 ] }
|
{ "LD-RR,RR" [ [ $3 ] keep $2 ] }
|
||||||
{ "LD-R,N" [ [ next-byte ] keep $2 ] }
|
{ "LD-R,N" [ [ next-byte ] keep $2 ] }
|
||||||
|
@ -737,7 +764,7 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
{ "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
|
{ "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
|
||||||
{ "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
|
{ "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
|
||||||
{ "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
|
{ "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
|
||||||
{ "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
|
{ "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 [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
|
||||||
{ "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
|
{ "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
|
||||||
} ;
|
} ;
|
||||||
|
@ -789,14 +816,14 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
#! Return a parser for then instruction identified by the token.
|
#! Return a parser for then instruction identified by the token.
|
||||||
#! The parser return parses the token only and expects no additional
|
#! The parser return parses the token only and expects no additional
|
||||||
#! arguments to the instruction.
|
#! arguments to the instruction.
|
||||||
token [ '[ { } , generate-instruction ] ] action ;
|
token [ '[ { } _ generate-instruction ] ] action ;
|
||||||
|
|
||||||
: complex-instruction ( type token -- parser )
|
: complex-instruction ( type token -- parser )
|
||||||
#! Return a parser for an instruction identified by the token.
|
#! Return a parser for an instruction identified by the token.
|
||||||
#! The instruction is expected to take additional arguments by
|
#! The instruction is expected to take additional arguments by
|
||||||
#! being combined with other parsers. Then 'type' is used for a lookup
|
#! being combined with other parsers. Then 'type' is used for a lookup
|
||||||
#! in a pattern hashtable to return the instruction quotation pattern.
|
#! in a pattern hashtable to return the instruction quotation pattern.
|
||||||
token swap [ nip '[ , generate-instruction ] ] curry action ;
|
token swap [ nip '[ _ generate-instruction ] ] curry action ;
|
||||||
|
|
||||||
: no-params ( ast -- ast )
|
: no-params ( ast -- ast )
|
||||||
first { } swap curry ;
|
first { } swap curry ;
|
||||||
|
@ -1347,7 +1374,7 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
IN-R,(N)-instruction ,
|
IN-R,(N)-instruction ,
|
||||||
EX-(RR),RR-instruction ,
|
EX-(RR),RR-instruction ,
|
||||||
EX-RR,RR-instruction ,
|
EX-RR,RR-instruction ,
|
||||||
] choice* [ call ] action ;
|
] choice* [ call( -- quot ) ] action ;
|
||||||
|
|
||||||
: instruction-quotations ( string -- emulate-quot )
|
: instruction-quotations ( string -- emulate-quot )
|
||||||
#! Given an instruction string, return the emulation quotation for
|
#! Given an instruction string, return the emulation quotation for
|
||||||
|
@ -1358,22 +1385,23 @@ SYMBOLS: $1 $2 $3 $4 ;
|
||||||
SYMBOL: last-instruction
|
SYMBOL: last-instruction
|
||||||
SYMBOL: last-opcode
|
SYMBOL: last-opcode
|
||||||
|
|
||||||
: parse-instructions ( list -- emulate-quot )
|
: parse-instructions ( list -- )
|
||||||
#! Process the list of strings, which should make
|
#! Process the list of strings, which should make
|
||||||
#! up an 8080 instruction, and output a quotation
|
#! up an 8080 instruction, and output a quotation
|
||||||
#! that would implement that instruction.
|
#! that would implement that instruction.
|
||||||
dup " " join instruction-quotations
|
dup " " join instruction-quotations
|
||||||
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
|
[
|
||||||
r> (( cpu -- )) define-declared ;
|
"_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
|
||||||
|
] dip (( cpu -- )) define-declared ;
|
||||||
|
|
||||||
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
|
SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
|
||||||
|
|
||||||
: cycles ( -- )
|
SYNTAX: cycles
|
||||||
#! Set the number of cycles for the last instruction that was defined.
|
#! Set the number of cycles for the last instruction that was defined.
|
||||||
scan string>number last-opcode global at instruction-cycles set-nth ; parsing
|
scan string>number last-opcode global at instruction-cycles set-nth ;
|
||||||
|
|
||||||
: opcode ( -- )
|
SYNTAX: opcode ( -- )
|
||||||
#! Set the opcode number for the last instruction that was defined.
|
#! Set the opcode number for the last instruction that was defined.
|
||||||
last-instruction global at 1quotation scan 16 base>
|
last-instruction global at 1quotation scan 16 base>
|
||||||
dup last-opcode global set-at set-instruction ; parsing
|
dup last-opcode global set-at set-instruction ;
|
||||||
|
|
|
@ -1,22 +1,41 @@
|
||||||
USING: kernel cpu.8080 cpu.8080.emulator math math io
|
USING:
|
||||||
tools.time combinators sequences io.files io.encodings.ascii ;
|
accessors
|
||||||
|
combinators
|
||||||
|
cpu.8080
|
||||||
|
cpu.8080.emulator
|
||||||
|
io
|
||||||
|
io.files
|
||||||
|
io.encodings.ascii
|
||||||
|
kernel
|
||||||
|
math
|
||||||
|
math.bits
|
||||||
|
sequences
|
||||||
|
tools.time
|
||||||
|
;
|
||||||
IN: cpu.8080.test
|
IN: cpu.8080.test
|
||||||
|
|
||||||
: step ( cpu -- )
|
: step ( cpu -- )
|
||||||
#! Run a single 8080 instruction
|
#! Run a single 8080 instruction
|
||||||
[ read-instruction ] keep ! n cpu
|
[ read-instruction ] keep ! n cpu
|
||||||
over get-cycles over inc-cycles
|
over get-cycles over inc-cycles
|
||||||
[ swap instructions case ] keep
|
[ swap instructions nth call( cpu -- ) ] keep
|
||||||
[ cpu-pc HEX: FFFF bitand ] keep
|
[ pc>> HEX: FFFF bitand ] keep
|
||||||
[ set-cpu-pc ] keep
|
[ (>>pc) ] keep
|
||||||
process-interrupts ;
|
process-interrupts ;
|
||||||
|
|
||||||
|
|
||||||
: test-step ( cpu -- cpu )
|
: test-step ( cpu -- cpu )
|
||||||
[ step ] keep dup cpu. ;
|
[ step ] keep dup cpu. ;
|
||||||
|
|
||||||
|
: invaders ( -- seq )
|
||||||
|
{
|
||||||
|
{ HEX: 0000 "invaders/invaders.h" }
|
||||||
|
{ HEX: 0800 "invaders/invaders.g" }
|
||||||
|
{ HEX: 1000 "invaders/invaders.f" }
|
||||||
|
{ HEX: 1800 "invaders/invaders.e" }
|
||||||
|
} ;
|
||||||
|
|
||||||
: test-cpu ( -- cpu )
|
: test-cpu ( -- cpu )
|
||||||
<cpu> "invaders.rom" over load-rom dup cpu. ;
|
<cpu> invaders over load-rom* dup cpu. ;
|
||||||
|
|
||||||
: test-n ( n -- )
|
: test-n ( n -- )
|
||||||
test-cpu swap [ test-step ] times drop ;
|
test-cpu swap [ test-step ] times drop ;
|
||||||
|
@ -25,7 +44,7 @@ IN: cpu.8080.test
|
||||||
[ dup step ] times ;
|
[ dup step ] times ;
|
||||||
|
|
||||||
: each-8bit ( n quot -- )
|
: each-8bit ( n quot -- )
|
||||||
8 -rot [ >r bit? r> call ] 2curry each ; inline
|
[ 8 <bits> ] dip each ; inline
|
||||||
|
|
||||||
: >ppm ( cpu filename -- cpu )
|
: >ppm ( cpu filename -- cpu )
|
||||||
#! Dump the current screen image to a ppm image file with the given name.
|
#! Dump the current screen image to a ppm image file with the given name.
|
||||||
|
@ -36,8 +55,8 @@ IN: cpu.8080.test
|
||||||
224 [
|
224 [
|
||||||
32 [
|
32 [
|
||||||
over 32 * over + HEX: 2400 + ! cpu h w addr
|
over 32 * over + HEX: 2400 + ! cpu h w addr
|
||||||
>r pick r> swap cpu-ram nth [
|
[ pick ] dip swap ram>> nth [
|
||||||
0 = [
|
[
|
||||||
" 0 0 0" write
|
" 0 0 0" write
|
||||||
] [
|
] [
|
||||||
" 1 1 1" write
|
" 1 1 1" write
|
|
@ -3,7 +3,7 @@
|
||||||
USING: help.syntax help.markup cpu.8080.emulator ;
|
USING: help.syntax help.markup cpu.8080.emulator ;
|
||||||
IN: lunar-rescue
|
IN: lunar-rescue
|
||||||
|
|
||||||
HELP: run
|
HELP: run-lunar
|
||||||
{ $description
|
{ $description
|
||||||
"Run the Lunar Rescue emulator in a new window." $nl
|
"Run the Lunar Rescue emulator in a new window." $nl
|
||||||
{ $link rom-root } " must be set to the directory containing the "
|
{ $link rom-root } " must be set to the directory containing the "
|
||||||
|
@ -26,7 +26,7 @@ ARTICLE: { "lunar-rescue" "lunar-rescue" } "Lunar Rescue Emulator"
|
||||||
"lrescue/lrescue.6"
|
"lrescue/lrescue.6"
|
||||||
}
|
}
|
||||||
"These are the same ROM files as used by MAME. To run the game use the "
|
"These are the same ROM files as used by MAME. To run the game use the "
|
||||||
{ $link run } " word." $nl
|
{ $link run-lunar } " word." $nl
|
||||||
"Keys:"
|
"Keys:"
|
||||||
{ $table
|
{ $table
|
||||||
{ "Backspace" "Insert Coin" }
|
{ "Backspace" "Insert Coin" }
|
|
@ -3,22 +3,29 @@
|
||||||
!
|
!
|
||||||
! Lunar Rescue: http://www.mameworld.net/maws/romset/lrescue
|
! Lunar Rescue: http://www.mameworld.net/maws/romset/lrescue
|
||||||
!
|
!
|
||||||
USING: kernel space-invaders cpu.8080 ui ;
|
USING:
|
||||||
|
cpu.8080
|
||||||
|
kernel
|
||||||
|
space-invaders
|
||||||
|
ui
|
||||||
|
;
|
||||||
IN: lunar-rescue
|
IN: lunar-rescue
|
||||||
|
|
||||||
TUPLE: lunar-rescue ;
|
TUPLE: lunar-rescue < space-invaders ;
|
||||||
|
|
||||||
: <lunar-rescue> ( -- cpu )
|
: <lunar-rescue> ( -- cpu )
|
||||||
<space-invaders> lunar-rescue construct-delegate ;
|
lunar-rescue new cpu-init ;
|
||||||
|
|
||||||
: run ( -- )
|
CONSTANT: rom-info {
|
||||||
"Lunar Rescue" <lunar-rescue> {
|
|
||||||
{ HEX: 0000 "lrescue/lrescue.1" }
|
{ HEX: 0000 "lrescue/lrescue.1" }
|
||||||
{ HEX: 0800 "lrescue/lrescue.2" }
|
{ HEX: 0800 "lrescue/lrescue.2" }
|
||||||
{ HEX: 1000 "lrescue/lrescue.3" }
|
{ HEX: 1000 "lrescue/lrescue.3" }
|
||||||
{ HEX: 1800 "lrescue/lrescue.4" }
|
{ HEX: 1800 "lrescue/lrescue.4" }
|
||||||
{ HEX: 4000 "lrescue/lrescue.5" }
|
{ HEX: 4000 "lrescue/lrescue.5" }
|
||||||
{ HEX: 4800 "lrescue/lrescue.6" }
|
{ HEX: 4800 "lrescue/lrescue.6" }
|
||||||
} [ (run) ] with-ui ;
|
}
|
||||||
|
|
||||||
MAIN: run
|
: run-lunar ( -- )
|
||||||
|
[ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: run-lunar
|
|
@ -3,7 +3,7 @@
|
||||||
USING: help.syntax help.markup cpu.8080.emulator ;
|
USING: help.syntax help.markup cpu.8080.emulator ;
|
||||||
IN: space-invaders
|
IN: space-invaders
|
||||||
|
|
||||||
HELP: run
|
HELP: run-invaders
|
||||||
{ $description
|
{ $description
|
||||||
"Run the Space Invaders emulator in a new window." $nl
|
"Run the Space Invaders emulator in a new window." $nl
|
||||||
{ $link rom-root } " must be set to the directory containing the "
|
{ $link rom-root } " must be set to the directory containing the "
|
||||||
|
@ -24,7 +24,7 @@ ARTICLE: { "space-invaders" "space-invaders" } "Space Invaders Emulator"
|
||||||
"invaders/invaders.h"
|
"invaders/invaders.h"
|
||||||
}
|
}
|
||||||
"These are the same ROM files as used by MAME. To run the game use the "
|
"These are the same ROM files as used by MAME. To run the game use the "
|
||||||
{ $link run } " word." $nl
|
{ $link run-invaders } " word." $nl
|
||||||
"Keys:"
|
"Keys:"
|
||||||
{ $table
|
{ $table
|
||||||
{ "Backspace" "Insert Coin" }
|
{ "Backspace" "Insert Coin" }
|
|
@ -1,19 +1,42 @@
|
||||||
! Copyright (C) 2006 Chris Double.
|
! Copyright (C) 2006 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
!
|
!
|
||||||
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
|
USING:
|
||||||
sequences kernel shuffle arrays io.files combinators ui.gestures
|
accessors
|
||||||
ui.gadgets ui.render opengl.gl system match
|
alien.c-types
|
||||||
ui byte-arrays combinators.lib qualified ;
|
alien.data
|
||||||
|
arrays
|
||||||
|
byte-arrays
|
||||||
|
calendar
|
||||||
|
combinators
|
||||||
|
cpu.8080
|
||||||
|
cpu.8080.emulator
|
||||||
|
io.files
|
||||||
|
io.pathnames
|
||||||
|
kernel
|
||||||
|
math
|
||||||
|
openal
|
||||||
|
opengl.gl
|
||||||
|
sequences
|
||||||
|
ui
|
||||||
|
ui.gadgets
|
||||||
|
ui.gestures
|
||||||
|
ui.render
|
||||||
|
;
|
||||||
QUALIFIED: threads
|
QUALIFIED: threads
|
||||||
|
QUALIFIED: system
|
||||||
IN: space-invaders
|
IN: space-invaders
|
||||||
|
|
||||||
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
|
<<
|
||||||
: game-width 224 ; inline
|
"uchar" require-c-array
|
||||||
: game-height 256 ; inline
|
>>
|
||||||
|
|
||||||
|
TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
|
||||||
|
CONSTANT: game-width 224
|
||||||
|
CONSTANT: game-height 256
|
||||||
|
|
||||||
: make-opengl-bitmap ( -- array )
|
: make-opengl-bitmap ( -- array )
|
||||||
game-height game-width 3 * * <byte-array> ;
|
game-height game-width 3 * * uchar <c-array> ;
|
||||||
|
|
||||||
: bitmap-index ( point -- index )
|
: bitmap-index ( point -- index )
|
||||||
#! Point is a {x y}.
|
#! Point is a {x y}.
|
||||||
|
@ -22,57 +45,59 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
|
||||||
: set-bitmap-pixel ( color point array -- )
|
: set-bitmap-pixel ( color point array -- )
|
||||||
#! 'color' is a {r g b}. Point is {x y}.
|
#! 'color' is a {r g b}. Point is {x y}.
|
||||||
[ bitmap-index ] dip ! color index array
|
[ bitmap-index ] dip ! color index array
|
||||||
[ [ first ] 2dip set-uchar-nth ] 3keep
|
[ [ first ] 2dip set-nth ] 3keep
|
||||||
[ [ second ] 2dip [ 1 + ] dip set-uchar-nth ] 3keep
|
[ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep
|
||||||
[ third ] 2dip [ 2 + ] dip set-uchar-nth ;
|
[ third ] 2dip [ 2 + ] dip set-nth ;
|
||||||
|
|
||||||
: get-bitmap-pixel ( point array -- color )
|
: get-bitmap-pixel ( point array -- color )
|
||||||
#! Point is a {x y}. color is a {r g b}
|
#! Point is a {x y}. color is a {r g b}
|
||||||
[ bitmap-index ] dip
|
[ bitmap-index ] dip
|
||||||
[ uint-nth ] 2keep
|
[ nth ] 2keep
|
||||||
[ [ 1 + ] dip uchar-nth ] 2keep
|
[ [ 1 + ] dip nth ] 2keep
|
||||||
[ 2 + ] dip uchar-nth 3array ;
|
[ 2 + ] dip nth 3array ;
|
||||||
|
|
||||||
: SOUND-SHOT ( -- number ) 0 ;
|
CONSTANT: SOUND-SHOT 0
|
||||||
: SOUND-UFO ( -- number ) 1 ;
|
CONSTANT: SOUND-UFO 1
|
||||||
: SOUND-BASE-HIT ( -- number ) 2 ;
|
CONSTANT: SOUND-BASE-HIT 2
|
||||||
: SOUND-INVADER-HIT ( -- number ) 3 ;
|
CONSTANT: SOUND-INVADER-HIT 3
|
||||||
: SOUND-WALK1 ( -- number ) 4 ;
|
CONSTANT: SOUND-WALK1 4
|
||||||
: SOUND-WALK2 ( -- number ) 5 ;
|
CONSTANT: SOUND-WALK2 5
|
||||||
: SOUND-WALK3 ( -- number ) 6 ;
|
CONSTANT: SOUND-WALK3 6
|
||||||
: SOUND-WALK4 ( -- number ) 7 ;
|
CONSTANT: SOUND-WALK4 7
|
||||||
: SOUND-UFO-HIT ( -- number ) 8 ;
|
CONSTANT: SOUND-UFO-HIT 8
|
||||||
|
|
||||||
: init-sound ( index cpu filename -- )
|
: init-sound ( index cpu filename -- )
|
||||||
swapd >r space-invaders-sounds nth AL_BUFFER r>
|
canonicalize-path swapd [ sounds>> nth AL_BUFFER ] dip
|
||||||
create-buffer-from-wav set-source-param ;
|
create-buffer-from-wav set-source-param ;
|
||||||
|
|
||||||
: init-sounds ( cpu -- )
|
: init-sounds ( cpu -- )
|
||||||
init-openal
|
init-openal
|
||||||
[ 9 gen-sources swap set-space-invaders-sounds ] keep
|
[ 9 gen-sources swap (>>sounds) ] keep
|
||||||
[ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep
|
[ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep
|
||||||
[ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep
|
[ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep
|
||||||
[ space-invaders-sounds SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
|
[ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
|
||||||
[ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
|
[ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
|
||||||
[ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep
|
[ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.Wav" init-sound ] keep
|
||||||
[ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep
|
[ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep
|
||||||
[ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep
|
[ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep
|
||||||
[ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep
|
[ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep
|
||||||
[ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep
|
[ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep
|
||||||
[ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
|
[ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
|
||||||
f swap set-space-invaders-looping? ;
|
f swap (>>looping?) ;
|
||||||
|
|
||||||
: <space-invaders> ( -- cpu )
|
: cpu-init ( cpu -- cpu )
|
||||||
<cpu> space-invaders construct-delegate
|
make-opengl-bitmap over (>>bitmap)
|
||||||
make-opengl-bitmap over set-space-invaders-bitmap
|
|
||||||
[ init-sounds ] keep
|
[ init-sounds ] keep
|
||||||
[ reset ] keep ;
|
[ reset ] keep ;
|
||||||
|
|
||||||
|
: <space-invaders> ( -- cpu )
|
||||||
|
space-invaders new cpu-init ;
|
||||||
|
|
||||||
: play-invaders-sound ( cpu sound -- )
|
: play-invaders-sound ( cpu sound -- )
|
||||||
swap space-invaders-sounds nth source-play ;
|
swap sounds>> nth source-play ;
|
||||||
|
|
||||||
: stop-invaders-sound ( cpu sound -- )
|
: stop-invaders-sound ( cpu sound -- )
|
||||||
swap space-invaders-sounds nth source-stop ;
|
swap sounds>> nth source-stop ;
|
||||||
|
|
||||||
: read-port1 ( cpu -- byte )
|
: read-port1 ( cpu -- byte )
|
||||||
#! Port 1 maps the keys for space invaders
|
#! Port 1 maps the keys for space invaders
|
||||||
|
@ -82,8 +107,8 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
|
||||||
#! Bit 4 = player one fire
|
#! Bit 4 = player one fire
|
||||||
#! Bit 5 = player one left
|
#! Bit 5 = player one left
|
||||||
#! Bit 6 = player one right
|
#! Bit 6 = player one right
|
||||||
[ space-invaders-port1 dup HEX: FE bitand ] keep
|
[ port1>> dup HEX: FE bitand ] keep
|
||||||
set-space-invaders-port1 ;
|
(>>port1) ;
|
||||||
|
|
||||||
: read-port2 ( cpu -- byte )
|
: read-port2 ( cpu -- byte )
|
||||||
#! Port 2 maps player 2 controls and dip switches
|
#! Port 2 maps player 2 controls and dip switches
|
||||||
|
@ -93,14 +118,14 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
|
||||||
#! Bit 5 = player two left
|
#! Bit 5 = player two left
|
||||||
#! Bit 6 = player two right
|
#! Bit 6 = player two right
|
||||||
#! Bit 7 = show or hide coin info
|
#! Bit 7 = show or hide coin info
|
||||||
[ space-invaders-port2i HEX: 8F bitand ] keep
|
[ port2i>> HEX: 8F bitand ] keep
|
||||||
space-invaders-port1 HEX: 70 bitand bitor ;
|
port1>> HEX: 70 bitand bitor ;
|
||||||
|
|
||||||
: read-port3 ( cpu -- byte )
|
: read-port3 ( cpu -- byte )
|
||||||
#! Used to compute a special formula
|
#! Used to compute a special formula
|
||||||
[ space-invaders-port4hi 8 shift ] keep
|
[ port4hi>> 8 shift ] keep
|
||||||
[ space-invaders-port4lo bitor ] keep
|
[ port4lo>> bitor ] keep
|
||||||
space-invaders-port2o shift -8 shift HEX: FF bitand ;
|
port2o>> shift -8 shift HEX: FF bitand ;
|
||||||
|
|
||||||
M: space-invaders read-port ( port cpu -- byte )
|
M: space-invaders read-port ( port cpu -- byte )
|
||||||
#! Read a byte from the hardware port. 'port' should
|
#! Read a byte from the hardware port. 'port' should
|
||||||
|
@ -114,16 +139,16 @@ M: space-invaders read-port ( port cpu -- byte )
|
||||||
|
|
||||||
: write-port2 ( value cpu -- )
|
: write-port2 ( value cpu -- )
|
||||||
#! Setting this value affects the value read from port 3
|
#! Setting this value affects the value read from port 3
|
||||||
set-space-invaders-port2o ;
|
(>>port2o) ;
|
||||||
|
|
||||||
: bit-newly-set? ( old-value new-value bit -- bool )
|
: bit-newly-set? ( old-value new-value bit -- bool )
|
||||||
tuck bit? >r bit? not r> and ;
|
tuck bit? [ bit? not ] dip and ;
|
||||||
|
|
||||||
: port3-newly-set? ( new-value cpu bit -- bool )
|
: port3-newly-set? ( new-value cpu bit -- bool )
|
||||||
>r space-invaders-port3o swap r> bit-newly-set? ;
|
[ port3o>> swap ] dip bit-newly-set? ;
|
||||||
|
|
||||||
: port5-newly-set? ( new-value cpu bit -- bool )
|
: port5-newly-set? ( new-value cpu bit -- bool )
|
||||||
>r space-invaders-port5o swap r> bit-newly-set? ;
|
[ port5o>> swap ] dip bit-newly-set? ;
|
||||||
|
|
||||||
: write-port3 ( value cpu -- )
|
: write-port3 ( value cpu -- )
|
||||||
#! Connected to the sound hardware
|
#! Connected to the sound hardware
|
||||||
|
@ -132,25 +157,25 @@ M: space-invaders read-port ( port cpu -- byte )
|
||||||
#! Bit 2 = Your ship hit
|
#! Bit 2 = Your ship hit
|
||||||
#! Bit 3 = Invader hit
|
#! Bit 3 = Invader hit
|
||||||
#! Bit 4 = Extended play sound
|
#! Bit 4 = Extended play sound
|
||||||
over 0 bit? over space-invaders-looping? not and [
|
over 0 bit? over looping?>> not and [
|
||||||
dup SOUND-UFO play-invaders-sound
|
dup SOUND-UFO play-invaders-sound
|
||||||
t over set-space-invaders-looping?
|
t over (>>looping?)
|
||||||
] when
|
] when
|
||||||
over 0 bit? not over space-invaders-looping? and [
|
over 0 bit? not over looping?>> and [
|
||||||
dup SOUND-UFO stop-invaders-sound
|
dup SOUND-UFO stop-invaders-sound
|
||||||
f over set-space-invaders-looping?
|
f over (>>looping?)
|
||||||
] when
|
] when
|
||||||
2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
|
2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
|
||||||
2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
|
2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
|
||||||
2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
|
2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
|
||||||
2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
|
2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
|
||||||
set-space-invaders-port3o ;
|
(>>port3o) ;
|
||||||
|
|
||||||
: write-port4 ( value cpu -- )
|
: write-port4 ( value cpu -- )
|
||||||
#! Affects the value returned by reading port 3
|
#! Affects the value returned by reading port 3
|
||||||
[ space-invaders-port4hi ] keep
|
[ port4hi>> ] keep
|
||||||
[ set-space-invaders-port4lo ] keep
|
[ (>>port4lo) ] keep
|
||||||
set-space-invaders-port4hi ;
|
(>>port4hi) ;
|
||||||
|
|
||||||
: write-port5 ( value cpu -- )
|
: write-port5 ( value cpu -- )
|
||||||
#! Plays sounds
|
#! Plays sounds
|
||||||
|
@ -165,7 +190,7 @@ M: space-invaders read-port ( port cpu -- byte )
|
||||||
2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
|
2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
|
||||||
2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
|
2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
|
||||||
2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
|
2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
|
||||||
set-space-invaders-port5o ;
|
(>>port5o) ;
|
||||||
|
|
||||||
M: space-invaders write-port ( value port cpu -- )
|
M: space-invaders write-port ( value port cpu -- )
|
||||||
#! Write a byte to the hardware port, where 'port' is
|
#! Write a byte to the hardware port, where 'port' is
|
||||||
|
@ -179,33 +204,34 @@ M: space-invaders write-port ( value port cpu -- )
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: space-invaders reset ( cpu -- )
|
M: space-invaders reset ( cpu -- )
|
||||||
[ delegate reset ] keep
|
dup call-next-method
|
||||||
[ 0 swap set-space-invaders-port1 ] keep
|
0 >>port1
|
||||||
[ 0 swap set-space-invaders-port2i ] keep
|
0 >>port2i
|
||||||
[ 0 swap set-space-invaders-port2o ] keep
|
0 >>port2o
|
||||||
[ 0 swap set-space-invaders-port3o ] keep
|
0 >>port3o
|
||||||
[ 0 swap set-space-invaders-port4lo ] keep
|
0 >>port4lo
|
||||||
[ 0 swap set-space-invaders-port4hi ] keep
|
0 >>port4hi
|
||||||
0 swap set-space-invaders-port5o ;
|
0 >>port5o
|
||||||
|
drop ;
|
||||||
|
|
||||||
: gui-step ( cpu -- )
|
: gui-step ( cpu -- )
|
||||||
[ read-instruction ] keep ! n cpu
|
[ read-instruction ] keep ! n cpu
|
||||||
over get-cycles over inc-cycles
|
over get-cycles over inc-cycles
|
||||||
[ swap instructions case ] keep
|
[ swap instructions nth call( cpu -- ) ] keep
|
||||||
[ cpu-pc HEX: FFFF bitand ] keep
|
[ pc>> HEX: FFFF bitand ] keep
|
||||||
set-cpu-pc ;
|
(>>pc) ;
|
||||||
|
|
||||||
: gui-frame/2 ( cpu -- )
|
: gui-frame/2 ( cpu -- )
|
||||||
[ gui-step ] keep
|
[ gui-step ] keep
|
||||||
[ cpu-cycles ] keep
|
[ cycles>> ] keep
|
||||||
over 16667 < [ ! cycles cpu
|
over 16667 < [ ! cycles cpu
|
||||||
nip gui-frame/2
|
nip gui-frame/2
|
||||||
] [
|
] [
|
||||||
[ >r 16667 - r> set-cpu-cycles ] keep
|
[ [ 16667 - ] dip (>>cycles) ] keep
|
||||||
dup cpu-last-interrupt HEX: 10 = [
|
dup last-interrupt>> HEX: 10 = [
|
||||||
HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
|
HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt
|
||||||
] [
|
] [
|
||||||
HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
|
HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt
|
||||||
] if
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
@ -213,77 +239,77 @@ M: space-invaders reset ( cpu -- )
|
||||||
dup gui-frame/2 gui-frame/2 ;
|
dup gui-frame/2 gui-frame/2 ;
|
||||||
|
|
||||||
: coin-down ( cpu -- )
|
: coin-down ( cpu -- )
|
||||||
[ space-invaders-port1 1 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> 1 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: coin-up ( cpu -- )
|
: coin-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 1 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 1 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
: player1-down ( cpu -- )
|
: player1-down ( cpu -- )
|
||||||
[ space-invaders-port1 4 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> 4 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: player1-up ( cpu -- )
|
: player1-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 4 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 4 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
: player2-down ( cpu -- )
|
: player2-down ( cpu -- )
|
||||||
[ space-invaders-port1 2 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> 2 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: player2-up ( cpu -- )
|
: player2-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 2 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 2 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
: fire-down ( cpu -- )
|
: fire-down ( cpu -- )
|
||||||
[ space-invaders-port1 HEX: 10 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> HEX: 10 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: fire-up ( cpu -- )
|
: fire-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 HEX: 10 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 HEX: 10 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
: left-down ( cpu -- )
|
: left-down ( cpu -- )
|
||||||
[ space-invaders-port1 HEX: 20 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> HEX: 20 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: left-up ( cpu -- )
|
: left-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 HEX: 20 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 HEX: 20 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
: right-down ( cpu -- )
|
: right-down ( cpu -- )
|
||||||
[ space-invaders-port1 HEX: 40 bitor ] keep set-space-invaders-port1 ;
|
[ port1>> HEX: 40 bitor ] keep (>>port1) ;
|
||||||
|
|
||||||
: right-up ( cpu -- )
|
: right-up ( cpu -- )
|
||||||
[ space-invaders-port1 255 HEX: 40 - bitand ] keep set-space-invaders-port1 ;
|
[ port1>> 255 HEX: 40 - bitand ] keep (>>port1) ;
|
||||||
|
|
||||||
|
|
||||||
TUPLE: invaders-gadget cpu quit? ;
|
TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
|
||||||
|
|
||||||
invaders-gadget H{
|
invaders-gadget H{
|
||||||
{ T{ key-down f f "ESC" } [ t swap set-invaders-gadget-quit? ] }
|
{ T{ key-down f f "ESC" } [ t over (>>quit?) dup windowed?>> [ close-window ] [ drop ] if ] }
|
||||||
{ T{ key-down f f "BACKSPACE" } [ invaders-gadget-cpu coin-down ] }
|
{ T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] }
|
||||||
{ T{ key-up f f "BACKSPACE" } [ invaders-gadget-cpu coin-up ] }
|
{ T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] }
|
||||||
{ T{ key-down f f "1" } [ invaders-gadget-cpu player1-down ] }
|
{ T{ key-down f f "1" } [ cpu>> player1-down ] }
|
||||||
{ T{ key-up f f "1" } [ invaders-gadget-cpu player1-up ] }
|
{ T{ key-up f f "1" } [ cpu>> player1-up ] }
|
||||||
{ T{ key-down f f "2" } [ invaders-gadget-cpu player2-down ] }
|
{ T{ key-down f f "2" } [ cpu>> player2-down ] }
|
||||||
{ T{ key-up f f "2" } [ invaders-gadget-cpu player2-up ] }
|
{ T{ key-up f f "2" } [ cpu>> player2-up ] }
|
||||||
{ T{ key-down f f "UP" } [ invaders-gadget-cpu fire-down ] }
|
{ T{ key-down f f "UP" } [ cpu>> fire-down ] }
|
||||||
{ T{ key-up f f "UP" } [ invaders-gadget-cpu fire-up ] }
|
{ T{ key-up f f "UP" } [ cpu>> fire-up ] }
|
||||||
{ T{ key-down f f "LEFT" } [ invaders-gadget-cpu left-down ] }
|
{ T{ key-down f f "LEFT" } [ cpu>> left-down ] }
|
||||||
{ T{ key-up f f "LEFT" } [ invaders-gadget-cpu left-up ] }
|
{ T{ key-up f f "LEFT" } [ cpu>> left-up ] }
|
||||||
{ T{ key-down f f "RIGHT" } [ invaders-gadget-cpu right-down ] }
|
{ T{ key-down f f "RIGHT" } [ cpu>> right-down ] }
|
||||||
{ T{ key-up f f "RIGHT" } [ invaders-gadget-cpu right-up ] }
|
{ T{ key-up f f "RIGHT" } [ cpu>> right-up ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: <invaders-gadget> ( cpu -- gadget )
|
: <invaders-gadget> ( cpu -- gadget )
|
||||||
invaders-gadget construct-gadget
|
invaders-gadget new
|
||||||
[ set-invaders-gadget-cpu ] keep
|
swap >>cpu
|
||||||
f over set-invaders-gadget-quit? ;
|
f >>quit? ;
|
||||||
|
|
||||||
M: invaders-gadget pref-dim* drop { 224 256 0 } ;
|
M: invaders-gadget pref-dim* drop { 224 256 } ;
|
||||||
|
|
||||||
M: invaders-gadget draw-gadget* ( gadget -- )
|
M: invaders-gadget draw-gadget* ( gadget -- )
|
||||||
0 0 glRasterPos2i
|
0 0 glRasterPos2i
|
||||||
1.0 -1.0 glPixelZoom
|
1.0 -1.0 glPixelZoom
|
||||||
>r 224 256 GL_RGB GL_UNSIGNED_BYTE r>
|
[ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip
|
||||||
invaders-gadget-cpu space-invaders-bitmap glDrawPixels ;
|
cpu>> bitmap>> glDrawPixels ;
|
||||||
|
|
||||||
: black { 0 0 0 } ;
|
CONSTANT: black { 0 0 0 }
|
||||||
: white { 255 255 255 } ;
|
CONSTANT: white { 255 255 255 }
|
||||||
: green { 0 255 0 } ;
|
CONSTANT: green { 0 255 0 }
|
||||||
: red { 255 0 0 } ;
|
CONSTANT: red { 255 0 0 }
|
||||||
|
|
||||||
: addr>xy ( addr -- point )
|
: addr>xy ( addr -- point )
|
||||||
#! Convert video RAM address to base X Y value. point is a {x y}.
|
#! Convert video RAM address to base X Y value. point is a {x y}.
|
||||||
|
@ -297,7 +323,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
|
||||||
|
|
||||||
: within ( n a b -- bool )
|
: within ( n a b -- bool )
|
||||||
#! n >= a and n <= b
|
#! n >= a and n <= b
|
||||||
rot tuck swap <= >r swap >= r> and ;
|
rot tuck swap <= [ swap >= ] dip and ;
|
||||||
|
|
||||||
: get-point-color ( point -- color )
|
: get-point-color ( point -- color )
|
||||||
#! Return the color to use for the given x/y position.
|
#! Return the color to use for the given x/y position.
|
||||||
|
@ -330,47 +356,51 @@ M: invaders-gadget draw-gadget* ( gadget -- )
|
||||||
|
|
||||||
M: space-invaders update-video ( value addr cpu -- )
|
M: space-invaders update-video ( value addr cpu -- )
|
||||||
over HEX: 2400 >= [
|
over HEX: 2400 >= [
|
||||||
space-invaders-bitmap -rot do-bitmap-update
|
bitmap>> -rot do-bitmap-update
|
||||||
] [
|
] [
|
||||||
3drop
|
3drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: sync-frame ( millis -- millis )
|
: sync-frame ( millis -- millis )
|
||||||
#! Sleep until the time for the next frame arrives.
|
#! Sleep until the time for the next frame arrives.
|
||||||
1000 60 / >fixnum + millis - dup 0 >
|
1000 60 / >fixnum + system:millis - dup 0 >
|
||||||
[ threads:sleep ] [ drop threads:yield ] if millis ;
|
[ milliseconds threads:sleep ] [ drop threads:yield ] if system:millis ;
|
||||||
|
|
||||||
: invaders-process ( millis gadget -- )
|
: invaders-process ( millis gadget -- )
|
||||||
#! Run a space invaders gadget inside a
|
#! Run a space invaders gadget inside a
|
||||||
#! concurrent process. Messages can be sent to
|
#! concurrent process. Messages can be sent to
|
||||||
#! signal key presses, etc.
|
#! signal key presses, etc.
|
||||||
dup invaders-gadget-quit? [
|
dup quit?>> [
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
[ sync-frame ] dip
|
[ sync-frame ] dip
|
||||||
[ invaders-gadget-cpu gui-frame ] keep
|
[ cpu>> gui-frame ] keep
|
||||||
[ relayout-1 ] keep
|
[ relayout-1 ] keep
|
||||||
invaders-process
|
invaders-process
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: invaders-gadget graft* ( gadget -- )
|
M: invaders-gadget graft* ( gadget -- )
|
||||||
dup invaders-gadget-cpu init-sounds
|
dup cpu>> init-sounds
|
||||||
f over set-invaders-gadget-quit?
|
f over (>>quit?)
|
||||||
[ millis swap invaders-process ] curry
|
[ system:millis swap invaders-process ] curry
|
||||||
"Space invaders" threads:spawn drop ;
|
"Space invaders" threads:spawn drop ;
|
||||||
|
|
||||||
M: invaders-gadget ungraft* ( gadget -- )
|
M: invaders-gadget ungraft* ( gadget -- )
|
||||||
t swap set-invaders-gadget-quit? ;
|
t swap (>>quit?) ;
|
||||||
|
|
||||||
: (run) ( title cpu rom-info -- )
|
: (run) ( title cpu rom-info -- )
|
||||||
over load-rom* <invaders-gadget> swap open-window ;
|
over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
|
||||||
|
|
||||||
: run ( -- )
|
CONSTANT: rom-info {
|
||||||
"Space Invaders" <space-invaders> {
|
{ HEX: 0000 "invaders/invaders.h" }
|
||||||
{ HEX: 0000 "invaders/invaders.h" }
|
{ HEX: 0800 "invaders/invaders.g" }
|
||||||
{ HEX: 0800 "invaders/invaders.g" }
|
{ HEX: 1000 "invaders/invaders.f" }
|
||||||
{ HEX: 1000 "invaders/invaders.f" }
|
{ HEX: 1800 "invaders/invaders.e" }
|
||||||
{ HEX: 1800 "invaders/invaders.e" }
|
}
|
||||||
} [ (run) ] with-ui ;
|
|
||||||
|
|
||||||
MAIN: run
|
: run-invaders ( -- )
|
||||||
|
[
|
||||||
|
"Space Invaders" <space-invaders> rom-info (run)
|
||||||
|
] with-ui ;
|
||||||
|
|
||||||
|
MAIN: run-invaders
|
Loading…
Reference in New Issue