steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

space invaders: more tests and fixes

cvs
Chris Double 2005-09-08 23:48:54 +00:00
parent dadffdf6e3
commit b3003e4759
2 changed files with 443 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
contrib/space-invaders/cpu.factor
View File

@ -155,6 +155,10 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port
#! A ^= quot call
[ cpu-a swap call bitxor ] keep set-cpu-a ; inline
: cpu-a-bitxor= ( value cpu -- )
#! cpu-a ^= value
[ cpu-a bitxor ] keep set-cpu-a ;
: cpu-f-bitand ( quot cpu -- )
#! F &= quot call
[ cpu-f swap call bitand ] keep set-cpu-f ; inline
@ -200,6 +204,10 @@ TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles port1 port2i port
#! cpu-f &= value
[ cpu-f bitand ] keep set-cpu-f ;
: cpu-f-bitxor= ( value cpu -- )
#! cpu-f ^= value
[ cpu-f bitxor ] keep set-cpu-f ;
: add-byte-to-a ( carry? n cpu -- )
#! Adds 'n' to the 'a' register. 'carry?' is try if
#! the carry flag should be considered in the add.
@ -736,6 +744,20 @@ C: cpu ( -- cpu )
[ " " write peek-instruction word-name write " " write ] keep
terpri drop ;
: cpu*. ( cpu -- )
[ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
[ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
[ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
[ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
[ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
[ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
[ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
[ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
[ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
[ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
terpri drop ;
: test-step ( cpu -- cpu )
[ step ] keep dup cpu. ;
@ -864,7 +886,7 @@ SYMBOL: $4
: (emulate-RLA) ( cpu -- )
dup cpu-a dup ( cpu old-a new-a )
1 shift pick set-cpu-a ( cpu old-a )
1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a )
over flag-c? [ [ 1 ] pick cpu-a-bitor ] when
[ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand
HEX: 80 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when
@ -872,7 +894,7 @@ SYMBOL: $4
: (emulate-RRA) ( cpu -- )
dup cpu-a dup ( cpu old-a new-a )
-1 shift pick set-cpu-a ( cpu old-a )
-1 shift HEX: FF bitand pick set-cpu-a ( cpu old-a )
over flag-c? [ [ HEX: 80 ] pick cpu-a-bitor ] when
[ add-sub-flag half-carry-flag carry-flag bitor bitor 255 swap - ] pick cpu-f-bitand
HEX: 01 bitand 0 = not [ [ carry-flag ] over cpu-f-bitor ] when
@ -925,8 +947,8 @@ SYMBOL: $4
[[ "OR-R" [ [ dup [ $1 ] cons swap cpu-a-bitor ] keep clear-and-set-flags-psz ] ]]
[[ "OR-(RR)" [ [ $1 ] keep [ read-byte unit ] keep [ cpu-a-bitor ] keep clear-and-set-flags-psz ] ]]
[[ "XOR-N" [ [ next-byte ] keep [ read-byte unit ] keep [ cpu-a-bitxor ] keep clear-and-set-flags-psz ] ]]
[[ "XOR-R" [ [ dup [ $1 ] cons swap cpu-a-bitxor ] keep clear-and-set-flags-psz ] ]]
[[ "XOR-(RR)" [ [ dup [ $1 ] cons swap cpu-a-bitxor ] keep clear-and-set-flags-psz ] ]]
[[ "XOR-R" [ [ $1 ] keep [ cpu-a-bitxor= ] keep clear-and-set-flags-psz ] ]]
[[ "XOR-(RR)" [ [ $1 ] keep [ read-byte ] keep [ cpu-a-bitxor= ] keep clear-and-set-flags-psz ] ]]
[[ "AND-A" [ clear-and-set-flags-psz ] ]]
[[ "AND-N" [ [ dup [ next-byte ] cons swap cpu-a-bitand ] keep clear-and-set-flags-psz ] ]]
[[ "AND-R" [ [ dup [ $1 ] cons swap cpu-a-bitand ] keep clear-and-set-flags-psz ] ]]
@ -937,7 +959,7 @@ SYMBOL: $4
[[ "ADD-R,N" [ [ f swap next-byte ] keep add-byte-to-a ] ]]
[[ "ADD-R,R" [ [ f swap $3 ] keep add-byte-to-a ] ]]
[[ "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep add-words ] ]]
[[ "ADD-R,(RR)" [ [ f swap $3 ] keep [ read-byte ] keep add-byte-to-a ] ]]
[[ "ADD-R,(RR)" [ [ f swap $3 ] keep [ read-byte ] keep add-byte-to-a ] ]]
[[ "SBC-R,N" [ [ cpu-f carry-flag bitand ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] ]]
[[ "SBC-R,R" [ drop "SBC-R,R Not Implemented" throw ] ]]
[[ "SBC-R,(RR)" [ drop "SBC-R,(RR) Not Implemented" throw ] ]]
@ -948,8 +970,8 @@ SYMBOL: $4
[[ "DAA" [ (emulate-DAA) ] ]]
[[ "RLA" [ (emulate-RLA) ] ]]
[[ "RRA" [ (emulate-RRA) ] ]]
[[ "CCF" [ [ carry-flag ] swap cpu-f-bitxor ] ]]
[[ "SCF" [ [ carry-flag ] swap cpu-f-bitor ] ]]
[[ "CCF" [ carry-flag swap cpu-f-bitxor= ] ]]
[[ "SCF" [ carry-flag swap cpu-f-bitor= ] ]]
[[ "RLCA" [ (emulate-RLCA) ] ]]
[[ "RRCA" [ (emulate-RRCA) ] ]]
[[ "HALT" [ drop "HALT not implemented" throw ] ]]

414
contrib/space-invaders/tests.factor
View File

@ -885,3 +885,417 @@ USING: kernel cpu-8080 test lazy parser-combinators math hashtables lists sequen
[ cpu-f ] keep
drop
] unit-test
[ emulate-LD_DE,nn 1 2 HEX: 0201 ] [
<cpu> HEX: 11 0 pick cpu-ram set-nth
1 1 pick cpu-ram set-nth
2 2 pick cpu-ram set-nth
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-e ] keep
[ cpu-d ] keep
[ cpu-de ] keep
drop
] unit-test
[ emulate-LD_(DE),A 1 ] [
<cpu> HEX: 12 0 pick cpu-ram set-nth
1 over set-cpu-a
HEX: 2000 over set-cpu-de
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ HEX: 2000 swap cpu-ram nth ] keep
drop
] unit-test
[ emulate-INC_DE HEX: 0001 HEX: 0100 HEX: 0000 ] [
<cpu> HEX: 13 0 pick cpu-ram set-nth
HEX: 0000 over set-cpu-de
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-de ] keep
HEX: 13 1 pick cpu-ram set-nth
HEX: 00FF over set-cpu-de
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-de ] keep
HEX: 13 2 pick cpu-ram set-nth
HEX: FFFF over set-cpu-de
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-de ] keep
drop
] unit-test
[ emulate-INC_D HEX: 01 f t f f f
HEX: 00 t f t f f
HEX: 80 f t t t t
HEX: 90 f t t f t
] [
<cpu> HEX: 14 0 pick cpu-ram set-nth
HEX: 00 over set-cpu-d
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 14 1 pick cpu-ram set-nth
HEX: FF over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 14 2 pick cpu-ram set-nth
HEX: 7F over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 14 3 pick cpu-ram set-nth
HEX: 8F over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-DEC_D HEX: FF f t t f t
HEX: 00 t f f f f
HEX: 7F f t t t f
HEX: 8F f t t f t
] [
<cpu> HEX: 15 0 pick cpu-ram set-nth
HEX: 00 over set-cpu-d
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 15 1 pick cpu-ram set-nth
HEX: 01 over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 15 2 pick cpu-ram set-nth
HEX: 80 over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
HEX: 15 3 pick cpu-ram set-nth
HEX: 90 over set-cpu-d
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ flag-z? ] keep
[ flag-nz? ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-LD_D,n 1 HEX: 0100 ] [
<cpu> HEX: 16 0 pick cpu-ram set-nth
1 1 pick cpu-ram set-nth
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-d ] keep
[ cpu-de ] keep
drop
] unit-test
[ emulate-RLA BIN: 11111110 0 BIN: 00000011 1 ] [
<cpu> HEX: 17 0 pick cpu-ram set-nth
0 over set-cpu-f
BIN: 01111111 over set-cpu-a
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f ] keep
HEX: 17 1 pick cpu-ram set-nth
19 over set-cpu-f
BIN: 10000001 over set-cpu-a
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f ] keep
drop
] unit-test
[ emulate-ADD_A,B HEX: 01 HEX: 01 f f f
HEX: 00 HEX: 01 t f t
HEX: A0 HEX: 50 f t f
] [
<cpu> HEX: 80 0 pick cpu-ram set-nth
HEX: 00 over set-cpu-a
HEX: 01 over set-cpu-b
0 over set-cpu-f
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-b ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 80 1 pick cpu-ram set-nth
HEX: FF over set-cpu-a
HEX: 01 over set-cpu-b
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-b ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 80 2 pick cpu-ram set-nth
HEX: 50 over set-cpu-a
HEX: 50 over set-cpu-b
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-b ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-ADD_A,C HEX: 01 HEX: 01 f f f
HEX: 00 HEX: 01 t f t
HEX: A0 HEX: 50 f t f
] [
<cpu> HEX: 81 0 pick cpu-ram set-nth
HEX: 00 over set-cpu-a
HEX: 01 over set-cpu-c
0 over set-cpu-f
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-c ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 81 1 pick cpu-ram set-nth
HEX: FF over set-cpu-a
HEX: 01 over set-cpu-c
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-c ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 81 2 pick cpu-ram set-nth
HEX: 50 over set-cpu-a
HEX: 50 over set-cpu-c
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-c ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-ADD_A,A HEX: 00 f f t
HEX: FE t t f
HEX: 00 t f t
] [
<cpu> HEX: 87 0 pick cpu-ram set-nth
HEX: 00 over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 87 1 pick cpu-ram set-nth
HEX: FF over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
HEX: 87 2 pick cpu-ram set-nth
HEX: 80 over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-SUB_n HEX: FF t f t t t f
HEX: 00 t t f f f f
HEX: DA t f t f f f
HEX: 7F t f f f t t
] [
<cpu> HEX: D6 0 pick cpu-ram set-nth
HEX: 01 1 pick cpu-ram set-nth
HEX: 00 over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: D6 2 pick cpu-ram set-nth
HEX: 02 3 pick cpu-ram set-nth
HEX: 02 over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: D6 4 pick cpu-ram set-nth
HEX: 25 5 pick cpu-ram set-nth
HEX: FF over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: D6 6 pick cpu-ram set-nth
HEX: 01 7 pick cpu-ram set-nth
HEX: 80 over set-cpu-a
0 over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-SBC_A,n HEX: FE t f t t t f
HEX: FF t f t t t f
HEX: D9 t f t f f f
HEX: 7E t f f f t t
] [
<cpu> HEX: DE 0 pick cpu-ram set-nth
HEX: 01 1 pick cpu-ram set-nth
HEX: 00 over set-cpu-a
HEX: FF over set-cpu-f
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: DE 2 pick cpu-ram set-nth
HEX: 02 3 pick cpu-ram set-nth
HEX: 02 over set-cpu-a
HEX: FF over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: DE 4 pick cpu-ram set-nth
HEX: 25 5 pick cpu-ram set-nth
HEX: FF over set-cpu-a
HEX: FF over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
HEX: DE 6 pick cpu-ram set-nth
HEX: 01 7 pick cpu-ram set-nth
HEX: 80 over set-cpu-a
HEX: FF over set-cpu-f
[ read-instruction instructions nth car ] keep
[ swap execute ] keep
[ cpu-a ] keep
[ cpu-f subtraction-flag bitand 0 = not ] keep
[ cpu-f zero-flag bitand 0 = not ] keep
[ cpu-f sign-flag bitand 0 = not ] keep
[ cpu-f carry-flag bitand 0 = not ] keep
[ cpu-f half-carry-flag bitand 0 = not ] keep
[ cpu-f overflow-flag bitand 0 = not ] keep
drop
] unit-test
[ emulate-EX_(SP),HL HEX: 41 HEX: 40 HEX: 5051 ] [
<cpu> HEX: E3 0 pick cpu-ram set-nth
HEX: 2021 over set-cpu-sp
HEX: 4041 over set-cpu-hl
HEX: 51 HEX: 2021 pick cpu-ram set-nth
HEX: 50 HEX: 2022 pick cpu-ram set-nth
[ read-instruction instructions nth car dup ] keep
[ swap execute ] keep
[ HEX: 2021 swap cpu-ram nth ] keep
[ HEX: 2022 swap cpu-ram nth ] keep
[ cpu-hl ] keep
drop
] unit-test