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

Part 1 of getting space invaders bit rot fixed

chris.double 2006-08-02 06:28:07 +00:00
parent 8a6cd181c4
commit be607eae1f
3 changed files with 98 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
contrib/parser-combinators/parser-combinators.factor
View File

@ -20,23 +20,27 @@
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USING: lazy-lists kernel sequences strings math io arrays ; USING: lazy-lists kernel sequences strings math io arrays errors ;
IN: parser-combinators IN: parser-combinators
TUPLE: parse-result parsed unparsed ; TUPLE: parse-result parsed unparsed ;
: h:t ( object -- head tail ) : h:t ( object -- head tail )
#! Return the head and tail of the object. #! Return the head and tail of the object.
dup first swap 1 tail ; dup empty? [ dup first swap 1 tail ] unless ;
: token-parser ( inp sequence -- llist ) : token-parser ( inp sequence -- llist )
#! A parser that parses a specific sequence of #! A parser that parses a specific sequence of
#! characters. #! characters.
[
2dup length head over = [ 2dup length head over = [
swap over length tail <parse-result> lunit swap over length tail <parse-result> lunit
] [ ] [
2drop nil 2drop nil
] if ; ] if
] [
3drop nil
] recover ;
: token ( string -- parser ) : token ( string -- parser )
#! Return a token parser that parses the given string. #! Return a token parser that parses the given string.

145
contrib/space-invaders/cpu-8080.factor
View File

@ -20,8 +20,8 @@
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USING: kernel lists math sequences errors vectors prettyprint io namespaces arrays USING: kernel math sequences errors vectors prettyprint io namespaces arrays
words parser hashtables lazy parser-combinators kernel-internals strings ; words parser hashtables lazy-lists parser-combinators kernel-internals strings ;
IN: cpu-8080 IN: cpu-8080
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@ -532,7 +532,7 @@ C: cpu ( cpu -- cpu )
: 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 car ; [ cpu-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 cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
@ -618,10 +618,10 @@ SYMBOL: $4
#! Copy the tree, replacing each occurence of #! Copy the tree, replacing each occurence of
#! $1, $2, etc with the relevant item from the #! $1, $2, etc with the relevant item from the
#! given index. #! given index.
dup cons? [ ( vector tree ) dup quotation? over [ ] = not and [ ( vector tree )
uncons ( vector car cdr ) dup first swap 1 tail ( vector car cdr )
>r dupd replace-patterns ( vector v R: cdr ) >r dupd replace-patterns ( vector v R: cdr )
swap r> replace-patterns cons swap r> replace-patterns >r unit r> append
] [ ( vector value ) ] [ ( vector value )
dup $1 = [ drop 0 over nth ] when dup $1 = [ drop 0 over nth ] when
dup $2 = [ drop 1 over nth ] when dup $2 = [ drop 1 over nth ] when
@ -863,7 +863,11 @@ SYMBOL: $4
#! 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 , ] [ ] make ] cons <@ ; token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
: >2array< ( array -- v1 v2 )
#! Explode a two element array
dup first swap second ;
: NOP-instruction ( -- parser ) : NOP-instruction ( -- parser )
"NOP" simple-instruction ; "NOP" simple-instruction ;
@ -871,74 +875,74 @@ SYMBOL: $4
: RET-NN-instruction ( -- parser ) : RET-NN-instruction ( -- parser )
"RET-NN" "RET" complex-instruction "RET-NN" "RET" complex-instruction
"nn" token sp <& "nn" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-0-instruction ( -- parser ) : RST-0-instruction ( -- parser )
"RST-0" "RST" complex-instruction "RST-0" "RST" complex-instruction
"0" token sp <& "0" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-8-instruction ( -- parser ) : RST-8-instruction ( -- parser )
"RST-8" "RST" complex-instruction "RST-8" "RST" complex-instruction
"8" token sp <& "8" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-10H-instruction ( -- parser ) : RST-10H-instruction ( -- parser )
"RST-10H" "RST" complex-instruction "RST-10H" "RST" complex-instruction
"10H" token sp <& "10H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-18H-instruction ( -- parser ) : RST-18H-instruction ( -- parser )
"RST-18H" "RST" complex-instruction "RST-18H" "RST" complex-instruction
"18H" token sp <& "18H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-20H-instruction ( -- parser ) : RST-20H-instruction ( -- parser )
"RST-20H" "RST" complex-instruction "RST-20H" "RST" complex-instruction
"20H" token sp <& "20H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-28H-instruction ( -- parser ) : RST-28H-instruction ( -- parser )
"RST-28H" "RST" complex-instruction "RST-28H" "RST" complex-instruction
"28H" token sp <& "28H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-30H-instruction ( -- parser ) : RST-30H-instruction ( -- parser )
"RST-30H" "RST" complex-instruction "RST-30H" "RST" complex-instruction
"30H" token sp <& "30H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: RST-38H-instruction ( -- parser ) : RST-38H-instruction ( -- parser )
"RST-38H" "RST" complex-instruction "RST-38H" "RST" complex-instruction
"38H" token sp <& "38H" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: JP-NN-instruction ( -- parser ) : JP-NN-instruction ( -- parser )
"JP-NN" "JP" complex-instruction "JP-NN" "JP" complex-instruction
"nn" token sp <& "nn" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: JP-F|FF,NN-instruction ( -- parser ) : JP-F|FF,NN-instruction ( -- parser )
"JP-F|FF,NN" "JP" complex-instruction "JP-F|FF,NN" "JP" complex-instruction
all-flags sp <&> all-flags sp <&>
",nn" token <& ",nn" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: JP-(RR)-instruction ( -- parser ) : JP-(RR)-instruction ( -- parser )
"JP-(RR)" "JP" complex-instruction "JP-(RR)" "JP" complex-instruction
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: CALL-NN-instruction ( -- parser ) : CALL-NN-instruction ( -- parser )
"CALL-NN" "CALL" complex-instruction "CALL-NN" "CALL" complex-instruction
"nn" token sp <& "nn" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: CALL-F|FF,NN-instruction ( -- parser ) : CALL-F|FF,NN-instruction ( -- parser )
"CALL-F|FF,NN" "CALL" complex-instruction "CALL-F|FF,NN" "CALL" complex-instruction
all-flags sp <&> all-flags sp <&>
",nn" token <& ",nn" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: RLCA-instruction ( -- parser ) : RLCA-instruction ( -- parser )
"RLCA" simple-instruction ; "RLCA" simple-instruction ;
@ -975,194 +979,194 @@ SYMBOL: $4
: DEC-R-instruction ( -- parser ) : DEC-R-instruction ( -- parser )
"DEC-R" "DEC" complex-instruction 8-bit-registers sp <&> "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: DEC-RR-instruction ( -- parser ) : DEC-RR-instruction ( -- parser )
"DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&> "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: DEC-(RR)-instruction ( -- parser ) : DEC-(RR)-instruction ( -- parser )
"DEC-(RR)" "DEC" complex-instruction "DEC-(RR)" "DEC" complex-instruction
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: POP-RR-instruction ( -- parser ) : POP-RR-instruction ( -- parser )
"POP-RR" "POP" complex-instruction all-registers sp <&> "POP-RR" "POP" complex-instruction all-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: PUSH-RR-instruction ( -- parser ) : PUSH-RR-instruction ( -- parser )
"PUSH-RR" "PUSH" complex-instruction all-registers sp <&> "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: INC-R-instruction ( -- parser ) : INC-R-instruction ( -- parser )
"INC-R" "INC" complex-instruction 8-bit-registers sp <&> "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: INC-RR-instruction ( -- parser ) : INC-RR-instruction ( -- parser )
"INC-RR" "INC" complex-instruction 16-bit-registers sp <&> "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: INC-(RR)-instruction ( -- parser ) : INC-(RR)-instruction ( -- parser )
"INC-(RR)" "INC" complex-instruction "INC-(RR)" "INC" complex-instruction
all-registers indirect sp <&> just [ uncons swons ] <@ ; all-registers indirect sp <&> just [ >2array< swap curry ] <@ ;
: RET-F|FF-instruction ( -- parser ) : RET-F|FF-instruction ( -- parser )
"RET-F|FF" "RET" complex-instruction all-flags sp <&> "RET-F|FF" "RET" complex-instruction all-flags sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: AND-N-instruction ( -- parser ) : AND-N-instruction ( -- parser )
"AND-N" "AND" complex-instruction "AND-N" "AND" complex-instruction
"n" token sp <& "n" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: AND-R-instruction ( -- parser ) : AND-R-instruction ( -- parser )
"AND-R" "AND" complex-instruction "AND-R" "AND" complex-instruction
8-bit-registers sp <&> just [ uncons swons ] <@ ; 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ;
: AND-(RR)-instruction ( -- parser ) : AND-(RR)-instruction ( -- parser )
"AND-(RR)" "AND" complex-instruction "AND-(RR)" "AND" complex-instruction
16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ;
: XOR-N-instruction ( -- parser ) : XOR-N-instruction ( -- parser )
"XOR-N" "XOR" complex-instruction "XOR-N" "XOR" complex-instruction
"n" token sp <& "n" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: XOR-R-instruction ( -- parser ) : XOR-R-instruction ( -- parser )
"XOR-R" "XOR" complex-instruction "XOR-R" "XOR" complex-instruction
8-bit-registers sp <&> just [ uncons swons ] <@ ; 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ;
: XOR-(RR)-instruction ( -- parser ) : XOR-(RR)-instruction ( -- parser )
"XOR-(RR)" "XOR" complex-instruction "XOR-(RR)" "XOR" complex-instruction
16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ;
: OR-N-instruction ( -- parser ) : OR-N-instruction ( -- parser )
"OR-N" "OR" complex-instruction "OR-N" "OR" complex-instruction
"n" token sp <& "n" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: OR-R-instruction ( -- parser ) : OR-R-instruction ( -- parser )
"OR-R" "OR" complex-instruction "OR-R" "OR" complex-instruction
8-bit-registers sp <&> just [ uncons swons ] <@ ; 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ;
: OR-(RR)-instruction ( -- parser ) : OR-(RR)-instruction ( -- parser )
"OR-(RR)" "OR" complex-instruction "OR-(RR)" "OR" complex-instruction
16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ;
: CP-N-instruction ( -- parser ) : CP-N-instruction ( -- parser )
"CP-N" "CP" complex-instruction "CP-N" "CP" complex-instruction
"n" token sp <& "n" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: CP-R-instruction ( -- parser ) : CP-R-instruction ( -- parser )
"CP-R" "CP" complex-instruction "CP-R" "CP" complex-instruction
8-bit-registers sp <&> just [ uncons swons ] <@ ; 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ;
: CP-(RR)-instruction ( -- parser ) : CP-(RR)-instruction ( -- parser )
"CP-(RR)" "CP" complex-instruction "CP-(RR)" "CP" complex-instruction
16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ;
: ADC-R,N-instruction ( -- parser ) : ADC-R,N-instruction ( -- parser )
"ADC-R,N" "ADC" complex-instruction "ADC-R,N" "ADC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
",n" token <& ",n" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: ADC-R,R-instruction ( -- parser ) : ADC-R,R-instruction ( -- parser )
"ADC-R,R" "ADC" complex-instruction "ADC-R,R" "ADC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: ADC-R,(RR)-instruction ( -- parser ) : ADC-R,(RR)-instruction ( -- parser )
"ADC-R,(RR)" "ADC" complex-instruction "ADC-R,(RR)" "ADC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers indirect <&> 16-bit-registers indirect <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: SBC-R,N-instruction ( -- parser ) : SBC-R,N-instruction ( -- parser )
"SBC-R,N" "SBC" complex-instruction "SBC-R,N" "SBC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
",n" token <& ",n" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: SBC-R,R-instruction ( -- parser ) : SBC-R,R-instruction ( -- parser )
"SBC-R,R" "SBC" complex-instruction "SBC-R,R" "SBC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: SBC-R,(RR)-instruction ( -- parser ) : SBC-R,(RR)-instruction ( -- parser )
"SBC-R,(RR)" "SBC" complex-instruction "SBC-R,(RR)" "SBC" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers indirect <&> 16-bit-registers indirect <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: SUB-R-instruction ( -- parser ) : SUB-R-instruction ( -- parser )
"SUB-R" "SUB" complex-instruction "SUB-R" "SUB" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: SUB-(RR)-instruction ( -- parser ) : SUB-(RR)-instruction ( -- parser )
"SUB-(RR)" "SUB" complex-instruction "SUB-(RR)" "SUB" complex-instruction
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: SUB-N-instruction ( -- parser ) : SUB-N-instruction ( -- parser )
"SUB-N" "SUB" complex-instruction "SUB-N" "SUB" complex-instruction
"n" token sp <& "n" token sp <&
just [ { } clone swons ] <@ ; just [ { } clone swap curry ] <@ ;
: ADD-R,N-instruction ( -- parser ) : ADD-R,N-instruction ( -- parser )
"ADD-R,N" "ADD" complex-instruction "ADD-R,N" "ADD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
",n" token <& ",n" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: ADD-R,R-instruction ( -- parser ) : ADD-R,R-instruction ( -- parser )
"ADD-R,R" "ADD" complex-instruction "ADD-R,R" "ADD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: ADD-RR,RR-instruction ( -- parser ) : ADD-RR,RR-instruction ( -- parser )
"ADD-RR,RR" "ADD" complex-instruction "ADD-RR,RR" "ADD" complex-instruction
16-bit-registers sp <&> 16-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers <&> 16-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: ADD-R,(RR)-instruction ( -- parser ) : ADD-R,(RR)-instruction ( -- parser )
"ADD-R,(RR)" "ADD" complex-instruction "ADD-R,(RR)" "ADD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers indirect <&> 16-bit-registers indirect <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: LD-RR,NN-instruction : LD-RR,NN-instruction
#! LD BC,nn #! LD BC,nn
"LD-RR,NN" "LD" complex-instruction "LD-RR,NN" "LD" complex-instruction
16-bit-registers sp <&> 16-bit-registers sp <&>
",nn" token <& ",nn" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-R,N-instruction : LD-R,N-instruction
#! LD B,n #! LD B,n
"LD-R,N" "LD" complex-instruction "LD-R,N" "LD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
",n" token <& ",n" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-(RR),N-instruction : LD-(RR),N-instruction
"LD-(RR),N" "LD" complex-instruction "LD-(RR),N" "LD" complex-instruction
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
",n" token <& ",n" token <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-(RR),R-instruction : LD-(RR),R-instruction
#! LD (BC),A #! LD (BC),A
@ -1170,84 +1174,84 @@ SYMBOL: $4
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: LD-R,R-instruction : LD-R,R-instruction
"LD-R,R" "LD" complex-instruction "LD-R,R" "LD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: LD-RR,RR-instruction : LD-RR,RR-instruction
"LD-RR,RR" "LD" complex-instruction "LD-RR,RR" "LD" complex-instruction
16-bit-registers sp <&> 16-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers <&> 16-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: LD-R,(RR)-instruction : LD-R,(RR)-instruction
"LD-R,(RR)" "LD" complex-instruction "LD-R,(RR)" "LD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers indirect <&> 16-bit-registers indirect <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: LD-(NN),RR-instruction : LD-(NN),RR-instruction
"LD-(NN),RR" "LD" complex-instruction "LD-(NN),RR" "LD" complex-instruction
"nn" token indirect sp <& "nn" token indirect sp <&
"," token <& "," token <&
16-bit-registers <&> 16-bit-registers <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-(NN),R-instruction : LD-(NN),R-instruction
"LD-(NN),R" "LD" complex-instruction "LD-(NN),R" "LD" complex-instruction
"nn" token indirect sp <& "nn" token indirect sp <&
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-RR,(NN)-instruction : LD-RR,(NN)-instruction
"LD-RR,(NN)" "LD" complex-instruction "LD-RR,(NN)" "LD" complex-instruction
16-bit-registers sp <&> 16-bit-registers sp <&>
"," token <& "," token <&
"nn" token indirect <& "nn" token indirect <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: LD-R,(NN)-instruction : LD-R,(NN)-instruction
"LD-R,(NN)" "LD" complex-instruction "LD-R,(NN)" "LD" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
"nn" token indirect <& "nn" token indirect <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: OUT-(N),R-instruction : OUT-(N),R-instruction
"OUT-(N),R" "OUT" complex-instruction "OUT-(N),R" "OUT" complex-instruction
"n" token indirect sp <& "n" token indirect sp <&
"," token <& "," token <&
8-bit-registers <&> 8-bit-registers <&>
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: IN-R,(N)-instruction : IN-R,(N)-instruction
"IN-R,(N)" "IN" complex-instruction "IN-R,(N)" "IN" complex-instruction
8-bit-registers sp <&> 8-bit-registers sp <&>
"," token <& "," token <&
"n" token indirect <& "n" token indirect <&
just [ uncons swons ] <@ ; just [ >2array< swap curry ] <@ ;
: EX-(RR),RR-instruction : EX-(RR),RR-instruction
"EX-(RR),RR" "EX" complex-instruction "EX-(RR),RR" "EX" complex-instruction
16-bit-registers indirect sp <&> 16-bit-registers indirect sp <&>
"," token <& "," token <&
16-bit-registers <&> 16-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: EX-RR,RR-instruction : EX-RR,RR-instruction
"EX-RR,RR" "EX" complex-instruction "EX-RR,RR" "EX" complex-instruction
16-bit-registers sp <&> 16-bit-registers sp <&>
"," token <& "," token <&
16-bit-registers <&> 16-bit-registers <&>
just [ unswons unswons >r swap append r> cons ] <@ ; just [ >2array< swap >2array< swap >r append r> curry ] <@ ;
: 8080-generator-parser : 8080-generator-parser
NOP-instruction NOP-instruction
@ -1355,7 +1359,6 @@ SYMBOL: last-opcode
last-instruction global hash unit scan 16 base> ( [word] opcode -- ) last-instruction global hash unit scan 16 base> ( [word] opcode -- )
dup last-opcode global set-hash instructions set-nth ; parsing dup last-opcode global set-hash instructions set-nth ; parsing
INSTRUCTION: NOP ; opcode 00 cycles 04 INSTRUCTION: NOP ; opcode 00 cycles 04
INSTRUCTION: LD BC,nn ; opcode 01 cycles 10 INSTRUCTION: LD BC,nn ; opcode 01 cycles 10
INSTRUCTION: LD (BC),A ; opcode 02 cycles 07 INSTRUCTION: LD (BC),A ; opcode 02 cycles 07

27
contrib/space-invaders/space-invaders.factor
View File

@ -21,7 +21,7 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USING: alien cpu-8080 errors generic io kernel kernel-internals USING: alien cpu-8080 errors generic io kernel kernel-internals
lists math namespaces sequences styles threads gadgets gadgets-layouts opengl arrays math namespaces sequences styles threads gadgets gadgets opengl arrays
concurrency ; concurrency ;
IN: space-invaders IN: space-invaders
@ -161,21 +161,22 @@ TUPLE: right-up-msg ;
<right-down-msg> over send [ 10 sleep <right-up-msg> swap send ] spawn drop ; <right-down-msg> over send [ 10 sleep <right-up-msg> swap send ] spawn drop ;
: set-key-actions ( gadget -- ) : set-key-actions ( gadget -- )
H{ ! H{
{ [ "ESCAPE" ] [ invaders-gadget-process "stop" swap send ] } ! { [ "ESCAPE" ] [ invaders-gadget-process "stop" swap send ] }
{ [ "BACKSPACE" ] [ invaders-gadget-process coin-key-pressed ] } ! { [ "BACKSPACE" ] [ invaders-gadget-process coin-key-pressed ] }
{ [ "1" ] [ invaders-gadget-process player1-key-pressed ] } ! { [ "1" ] [ invaders-gadget-process player1-key-pressed ] }
{ [ "2" ] [ invaders-gadget-process player2-key-pressed ] } ! { [ "2" ] [ invaders-gadget-process player2-key-pressed ] }
{ [ "UP" ] [ invaders-gadget-process fire-key-pressed ] } ! { [ "UP" ] [ invaders-gadget-process fire-key-pressed ] }
{ [ "LEFT" ] [ invaders-gadget-process left-key-pressed ] } ! { [ "LEFT" ] [ invaders-gadget-process left-key-pressed ] }
{ [ "RIGHT" ] [ invaders-gadget-process right-key-pressed ] } ! { [ "RIGHT" ] [ invaders-gadget-process right-key-pressed ] }
} add-actions ; ! } set-gestures
drop ;
C: invaders-gadget ( gadget -- ) C: invaders-gadget ( gadget -- )
dup delegate>gadget dup delegate>gadget
dup set-key-actions ; dup set-key-actions ;
M: invaders-gadget pref-dim* drop { 224 256 0 0 } ; M: invaders-gadget pref-dim* drop { 224 256 0 } ;
M: invaders-gadget draw-gadget* ( gadget -- ) M: invaders-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i 0 0 glRasterPos2i
@ -322,6 +323,6 @@ M: right-up-msg handle-invaders-message ( gadget message -- quit? )
: run ( -- process ) : run ( -- process )
<space-invaders> "invaders.rom" over load-rom <space-invaders> "invaders.rom" over load-rom
<invaders-gadget> [ set-invaders-gadget-cpu ] keep <invaders-gadget> [ set-invaders-gadget-cpu ] keep
dup "Space Invaders" open-window dup "Space Invaders" open-titled-window
dup [ millis swap invaders-process ] cons spawn dup [ millis swap invaders-process ] curry spawn
swap dupd set-invaders-gadget-process ; swap dupd set-invaders-gadget-process ;