From 77216b9d6893e714a4fcc849aae17c9133f4ecd5 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 15 Oct 2009 17:33:44 +1300 Subject: [PATCH 1/4] Fix cpu.8080 bitrot --- basis/peg/peg.factor | 4 +- unmaintained/cpu/8080/8080-docs.factor | 16 - unmaintained/cpu/8080/8080.factor | 251 --- unmaintained/cpu/8080/authors.txt | 1 - unmaintained/cpu/8080/emulator/authors.txt | 1 - .../cpu/8080/emulator/emulator-docs.factor | 36 - .../cpu/8080/emulator/emulator.factor | 1379 ----------------- unmaintained/cpu/8080/emulator/summary.txt | 1 - unmaintained/cpu/8080/emulator/tags.txt | 1 - unmaintained/cpu/8080/summary.txt | 1 - unmaintained/cpu/8080/tags.txt | 1 - unmaintained/cpu/8080/test/test.factor | 51 - 12 files changed, 2 insertions(+), 1741 deletions(-) delete mode 100644 unmaintained/cpu/8080/8080-docs.factor delete mode 100755 unmaintained/cpu/8080/8080.factor delete mode 100644 unmaintained/cpu/8080/authors.txt delete mode 100644 unmaintained/cpu/8080/emulator/authors.txt delete mode 100644 unmaintained/cpu/8080/emulator/emulator-docs.factor delete mode 100755 unmaintained/cpu/8080/emulator/emulator.factor delete mode 100644 unmaintained/cpu/8080/emulator/summary.txt delete mode 100644 unmaintained/cpu/8080/emulator/tags.txt delete mode 100644 unmaintained/cpu/8080/summary.txt delete mode 100644 unmaintained/cpu/8080/tags.txt delete mode 100755 unmaintained/cpu/8080/test/test.factor diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 42530151be..9e777b86af 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -502,10 +502,10 @@ TUPLE: action-parser p1 quot ; : check-action ( result quot -- result ) over [ - over ast>> swap call >>ast + over ast>> swap call( ast -- ast ) >>ast ] [ drop - ] if ; inline + ] if ; M: action-parser (compile) ( peg -- quot ) [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ; diff --git a/unmaintained/cpu/8080/8080-docs.factor b/unmaintained/cpu/8080/8080-docs.factor deleted file mode 100644 index 48b68360cb..0000000000 --- a/unmaintained/cpu/8080/8080-docs.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings cpu.8080.emulator ; -IN: cpu.8080 - - -ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator" -"The cpu-8080 library provides an emulator for the Intel 8080 CPU" -" instruction set. It is complete enough to emulate some 8080" -" based arcade games." $nl -"The emulated CPU can load 'ROM' files from disk using the " -{ $link load-rom } " and " { $link load-rom* } " words. These expect " -"the " { $link rom-root } " variable to be set to the path " -"containing the ROM file's." ; - -ABOUT: { "cpu-8080" "cpu-8080" } diff --git a/unmaintained/cpu/8080/8080.factor b/unmaintained/cpu/8080/8080.factor deleted file mode 100755 index 45a5129a72..0000000000 --- a/unmaintained/cpu/8080/8080.factor +++ /dev/null @@ -1,251 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: cpu.8080.emulator tools.time ; -IN: cpu.8080 - -INSTRUCTION: NOP ; opcode 00 cycles 04 -INSTRUCTION: LD BC,nn ; opcode 01 cycles 10 -INSTRUCTION: LD (BC),A ; opcode 02 cycles 07 -INSTRUCTION: INC BC ; opcode 03 cycles 06 -INSTRUCTION: INC B ; opcode 04 cycles 05 -INSTRUCTION: DEC B ; opcode 05 cycles 05 -INSTRUCTION: LD B,n ; opcode 06 cycles 07 -INSTRUCTION: RLCA ; opcode 07 cycles 04 -! INSTRUCTION: NOP ; opcode 08 cycles 04 -INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11 -INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07 -INSTRUCTION: DEC BC ; opcode 0B cycles 06 -INSTRUCTION: INC C ; opcode 0C cycles 05 -INSTRUCTION: DEC C ; opcode 0D cycles 05 -INSTRUCTION: LD C,n ; opcode 0E cycles 07 -INSTRUCTION: RRCA ; opcode 0F cycles 04 -INSTRUCTION: LD DE,nn ; opcode 11 cycles 10 -INSTRUCTION: LD (DE),A ; opcode 12 cycles 07 -INSTRUCTION: INC DE ; opcode 13 cycles 06 -INSTRUCTION: INC D ; opcode 14 cycles 05 -INSTRUCTION: DEC D ; opcode 15 cycles 05 -INSTRUCTION: LD D,n ; opcode 16 cycles 07 -INSTRUCTION: RLA ; opcode 17 cycles 04 -INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11 -INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07 -INSTRUCTION: DEC DE ; opcode 1B cycles 06 -INSTRUCTION: INC E ; opcode 1C cycles 05 -INSTRUCTION: DEC E ; opcode 1D cycles 05 -INSTRUCTION: LD E,n ; opcode 1E cycles 07 -INSTRUCTION: RRA ; opcode 1F cycles 04 -INSTRUCTION: LD HL,nn ; opcode 21 cycles 10 -INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16 -INSTRUCTION: INC HL ; opcode 23 cycles 06 -INSTRUCTION: INC H ; opcode 24 cycles 05 -INSTRUCTION: DEC H ; opcode 25 cycles 05 -INSTRUCTION: LD H,n ; opcode 26 cycles 07 -INSTRUCTION: DAA ; opcode 27 cycles 04 -INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11 -INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16 -INSTRUCTION: DEC HL ; opcode 2B cycles 06 -INSTRUCTION: INC L ; opcode 2C cycles 05 -INSTRUCTION: DEC L ; opcode 2D cycles 05 -INSTRUCTION: LD L,n ; opcode 2E cycles 07 -INSTRUCTION: CPL ; opcode 2F cycles 04 -INSTRUCTION: LD SP,nn ; opcode 31 cycles 10 -INSTRUCTION: LD (nn),A ; opcode 32 cycles 13 -INSTRUCTION: INC SP ; opcode 33 cycles 06 -INSTRUCTION: INC (HL) ; opcode 34 cycles 10 -INSTRUCTION: DEC (HL) ; opcode 35 cycles 10 -INSTRUCTION: LD (HL),n ; opcode 36 cycles 10 -INSTRUCTION: SCF ; opcode 37 cycles 04 -INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11 -INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13 -INSTRUCTION: DEC SP ; opcode 3B cycles 06 -INSTRUCTION: INC A ; opcode 3C cycles 05 -INSTRUCTION: DEC A ; opcode 3D cycles 05 -INSTRUCTION: LD A,n ; opcode 3E cycles 07 -INSTRUCTION: CCF ; opcode 3F cycles 04 -INSTRUCTION: LD B,B ; opcode 40 cycles 05 -INSTRUCTION: LD B,C ; opcode 41 cycles 05 -INSTRUCTION: LD B,D ; opcode 42 cycles 05 -INSTRUCTION: LD B,E ; opcode 43 cycles 05 -INSTRUCTION: LD B,H ; opcode 44 cycles 05 -INSTRUCTION: LD B,L ; opcode 45 cycles 05 -INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07 -INSTRUCTION: LD B,A ; opcode 47 cycles 05 -INSTRUCTION: LD C,B ; opcode 48 cycles 05 -INSTRUCTION: LD C,C ; opcode 49 cycles 05 -INSTRUCTION: LD C,D ; opcode 4A cycles 05 -INSTRUCTION: LD C,E ; opcode 4B cycles 05 -INSTRUCTION: LD C,H ; opcode 4C cycles 05 -INSTRUCTION: LD C,L ; opcode 4D cycles 05 -INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07 -INSTRUCTION: LD C,A ; opcode 4F cycles 05 -INSTRUCTION: LD D,B ; opcode 50 cycles 05 -INSTRUCTION: LD D,C ; opcode 51 cycles 05 -INSTRUCTION: LD D,D ; opcode 52 cycles 05 -INSTRUCTION: LD D,E ; opcode 53 cycles 05 -INSTRUCTION: LD D,H ; opcode 54 cycles 05 -INSTRUCTION: LD D,L ; opcode 55 cycles 05 -INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07 -INSTRUCTION: LD D,A ; opcode 57 cycles 05 -INSTRUCTION: LD E,B ; opcode 58 cycles 05 -INSTRUCTION: LD E,C ; opcode 59 cycles 05 -INSTRUCTION: LD E,D ; opcode 5A cycles 05 -INSTRUCTION: LD E,E ; opcode 5B cycles 05 -INSTRUCTION: LD E,H ; opcode 5C cycles 05 -INSTRUCTION: LD E,L ; opcode 5D cycles 05 -INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07 -INSTRUCTION: LD E,A ; opcode 5F cycles 05 -INSTRUCTION: LD H,B ; opcode 60 cycles 05 -INSTRUCTION: LD H,C ; opcode 61 cycles 05 -INSTRUCTION: LD H,D ; opcode 62 cycles 05 -INSTRUCTION: LD H,E ; opcode 63 cycles 05 -INSTRUCTION: LD H,H ; opcode 64 cycles 05 -INSTRUCTION: LD H,L ; opcode 65 cycles 05 -INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07 -INSTRUCTION: LD H,A ; opcode 67 cycles 05 -INSTRUCTION: LD L,B ; opcode 68 cycles 05 -INSTRUCTION: LD L,C ; opcode 69 cycles 05 -INSTRUCTION: LD L,D ; opcode 6A cycles 05 -INSTRUCTION: LD L,E ; opcode 6B cycles 05 -INSTRUCTION: LD L,H ; opcode 6C cycles 05 -INSTRUCTION: LD L,L ; opcode 6D cycles 05 -INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07 -INSTRUCTION: LD L,A ; opcode 6F cycles 05 -INSTRUCTION: LD (HL),B ; opcode 70 cycles 07 -INSTRUCTION: LD (HL),C ; opcode 71 cycles 07 -INSTRUCTION: LD (HL),D ; opcode 72 cycles 07 -INSTRUCTION: LD (HL),E ; opcode 73 cycles 07 -INSTRUCTION: LD (HL),H ; opcode 74 cycles 07 -INSTRUCTION: LD (HL),L ; opcode 75 cycles 07 -INSTRUCTION: HALT ; opcode 76 cycles 07 -INSTRUCTION: LD (HL),A ; opcode 77 cycles 07 -INSTRUCTION: LD A,B ; opcode 78 cycles 05 -INSTRUCTION: LD A,C ; opcode 79 cycles 05 -INSTRUCTION: LD A,D ; opcode 7A cycles 05 -INSTRUCTION: LD A,E ; opcode 7B cycles 05 -INSTRUCTION: LD A,H ; opcode 7C cycles 05 -INSTRUCTION: LD A,L ; opcode 7D cycles 05 -INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07 -INSTRUCTION: LD A,A ; opcode 7F cycles 05 -INSTRUCTION: ADD A,B ; opcode 80 cycles 04 -INSTRUCTION: ADD A,C ; opcode 81 cycles 04 -INSTRUCTION: ADD A,D ; opcode 82 cycles 04 -INSTRUCTION: ADD A,E ; opcode 83 cycles 04 -INSTRUCTION: ADD A,H ; opcode 84 cycles 04 -INSTRUCTION: ADD A,L ; opcode 85 cycles 04 -INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07 -INSTRUCTION: ADD A,A ; opcode 87 cycles 04 -INSTRUCTION: ADC A,B ; opcode 88 cycles 04 -INSTRUCTION: ADC A,C ; opcode 89 cycles 04 -INSTRUCTION: ADC A,D ; opcode 8A cycles 04 -INSTRUCTION: ADC A,E ; opcode 8B cycles 04 -INSTRUCTION: ADC A,H ; opcode 8C cycles 04 -INSTRUCTION: ADC A,L ; opcode 8D cycles 04 -INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07 -INSTRUCTION: ADC A,A ; opcode 8F cycles 04 -INSTRUCTION: SUB B ; opcode 90 cycles 04 -INSTRUCTION: SUB C ; opcode 91 cycles 04 -INSTRUCTION: SUB D ; opcode 92 cycles 04 -INSTRUCTION: SUB E ; opcode 93 cycles 04 -INSTRUCTION: SUB H ; opcode 94 cycles 04 -INSTRUCTION: SUB L ; opcode 95 cycles 04 -INSTRUCTION: SUB (HL) ; opcode 96 cycles 07 -INSTRUCTION: SUB A ; opcode 97 cycles 04 -INSTRUCTION: SBC A,B ; opcode 98 cycles 04 -INSTRUCTION: SBC A,C ; opcode 99 cycles 04 -INSTRUCTION: SBC A,D ; opcode 9A cycles 04 -INSTRUCTION: SBC A,E ; opcode 9B cycles 04 -INSTRUCTION: SBC A,H ; opcode 9C cycles 04 -INSTRUCTION: SBC A,L ; opcode 9D cycles 04 -INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07 -INSTRUCTION: SBC A,A ; opcode 9F cycles 04 -INSTRUCTION: AND B ; opcode A0 cycles 04 -INSTRUCTION: AND C ; opcode A1 cycles 04 -INSTRUCTION: AND D ; opcode A2 cycles 04 -INSTRUCTION: AND E ; opcode A3 cycles 04 -INSTRUCTION: AND H ; opcode A4 cycles 04 -INSTRUCTION: AND L ; opcode A5 cycles 04 -INSTRUCTION: AND (HL) ; opcode A6 cycles 07 -INSTRUCTION: AND A ; opcode A7 cycles 04 -INSTRUCTION: XOR B ; opcode A8 cycles 04 -INSTRUCTION: XOR C ; opcode A9 cycles 04 -INSTRUCTION: XOR D ; opcode AA cycles 04 -INSTRUCTION: XOR E ; opcode AB cycles 04 -INSTRUCTION: XOR H ; opcode AC cycles 04 -INSTRUCTION: XOR L ; opcode AD cycles 04 -INSTRUCTION: XOR (HL) ; opcode AE cycles 07 -INSTRUCTION: XOR A ; opcode AF cycles 04 -INSTRUCTION: OR B ; opcode B0 cycles 04 -INSTRUCTION: OR C ; opcode B1 cycles 04 -INSTRUCTION: OR D ; opcode B2 cycles 04 -INSTRUCTION: OR E ; opcode B3 cycles 04 -INSTRUCTION: OR H ; opcode B4 cycles 04 -INSTRUCTION: OR L ; opcode B5 cycles 04 -INSTRUCTION: OR (HL) ; opcode B6 cycles 07 -INSTRUCTION: OR A ; opcode B7 cycles 04 -INSTRUCTION: CP B ; opcode B8 cycles 04 -INSTRUCTION: CP C ; opcode B9 cycles 04 -INSTRUCTION: CP D ; opcode BA cycles 04 -INSTRUCTION: CP E ; opcode BB cycles 04 -INSTRUCTION: CP H ; opcode BC cycles 04 -INSTRUCTION: CP L ; opcode BD cycles 04 -INSTRUCTION: CP (HL) ; opcode BE cycles 07 -INSTRUCTION: CP A ; opcode BF cycles 04 -INSTRUCTION: RET NZ ; opcode C0 cycles 05 -INSTRUCTION: POP BC ; opcode C1 cycles 10 -INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10 -INSTRUCTION: JP nn ; opcode C3 cycles 10 -INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11 -INSTRUCTION: PUSH BC ; opcode C5 cycles 11 -INSTRUCTION: ADD A,n ; opcode C6 cycles 07 -INSTRUCTION: RST 0 ; opcode C7 cycles 11 -INSTRUCTION: RET Z ; opcode C8 cycles 05 -INSTRUCTION: RET nn ; opcode C9 cycles 10 -INSTRUCTION: JP Z,nn ; opcode CA cycles 10 -INSTRUCTION: CALL Z,nn ; opcode CC cycles 11 -INSTRUCTION: CALL nn ; opcode CD cycles 17 -INSTRUCTION: ADC A,n ; opcode CE cycles 07 -INSTRUCTION: RST 8 ; opcode CF cycles 11 -INSTRUCTION: RET NC ; opcode D0 cycles 05 -INSTRUCTION: POP DE ; opcode D1 cycles 10 -INSTRUCTION: JP NC,nn ; opcode D2 cycles 10 -INSTRUCTION: OUT (n),A ; opcode D3 cycles 10 -INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11 -INSTRUCTION: PUSH DE ; opcode D5 cycles 11 -INSTRUCTION: SUB n ; opcode D6 cycles 07 -INSTRUCTION: RST 10H ; opcode D7 cycles 11 -INSTRUCTION: RET C ; opcode D8 cycles 05 -INSTRUCTION: JP C,nn ; opcode DA cycles 10 -INSTRUCTION: IN A,(n) ; opcode DB cycles 10 -INSTRUCTION: CALL C,nn ; opcode DC cycles 11 -INSTRUCTION: SBC A,n ; opcode DE cycles 07 -INSTRUCTION: RST 18H ; opcode DF cycles 11 -INSTRUCTION: RET PO ; opcode E0 cycles 05 -INSTRUCTION: POP HL ; opcode E1 cycles 10 -INSTRUCTION: JP PO,nn ; opcode E2 cycles 10 -INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04 -INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11 -INSTRUCTION: PUSH HL ; opcode E5 cycles 11 -INSTRUCTION: AND n ; opcode E6 cycles 07 -INSTRUCTION: RST 20H ; opcode E7 cycles 11 -INSTRUCTION: RET PE ; opcode E8 cycles 05 -INSTRUCTION: JP (HL) ; opcode E9 cycles 04 -INSTRUCTION: JP PE,nn ; opcode EA cycles 10 -INSTRUCTION: EX DE,HL ; opcode EB cycles 04 -INSTRUCTION: CALL PE,nn ; opcode EC cycles 11 -INSTRUCTION: XOR n ; opcode EE cycles 07 -INSTRUCTION: RST 28H ; opcode EF cycles 11 -INSTRUCTION: RET P ; opcode F0 cycles 05 -INSTRUCTION: POP AF ; opcode F1 cycles 10 -INSTRUCTION: JP P,nn ; opcode F2 cycles 10 -INSTRUCTION: DI ; opcode F3 cycles 04 -INSTRUCTION: CALL P,nn ; opcode F4 cycles 11 -INSTRUCTION: PUSH AF ; opcode F5 cycles 11 -INSTRUCTION: OR n ; opcode F6 cycles 07 -INSTRUCTION: RST 30H ; opcode F7 cycles 11 -INSTRUCTION: RET M ; opcode F8 cycles 05 -INSTRUCTION: LD SP,HL ; opcode F9 cycles 06 -INSTRUCTION: JP M,nn ; opcode FA cycles 10 -INSTRUCTION: EI ; opcode FB cycles 04 -INSTRUCTION: CALL M,nn ; opcode FC cycles 11 -INSTRUCTION: CP n ; opcode FE cycles 07 -INSTRUCTION: RST 38H ; opcode FF cycles 11 diff --git a/unmaintained/cpu/8080/authors.txt b/unmaintained/cpu/8080/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/cpu/8080/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/cpu/8080/emulator/authors.txt b/unmaintained/cpu/8080/emulator/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/cpu/8080/emulator/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/cpu/8080/emulator/emulator-docs.factor b/unmaintained/cpu/8080/emulator/emulator-docs.factor deleted file mode 100644 index 438b5cf268..0000000000 --- a/unmaintained/cpu/8080/emulator/emulator-docs.factor +++ /dev/null @@ -1,36 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings ; -IN: cpu.8080.emulator - -HELP: load-rom -{ $values { "filename" string } { "cpu" cpu } } -{ $description -"Read the ROM file into the cpu's memory starting at address 0000. " -"The filename is relative to the path stored in the " { $link rom-root } -" variable. An exception is thrown if this variable is not set." -} -{ $see-also load-rom* } ; - -HELP: load-rom* -{ $values { "seq" sequence } { "cpu" cpu } } -{ $description -"Loads one or more ROM files into the cpu's memory. Each file is " -"loaded at a particular starting address. 'seq' is a sequence of " -"2 element arrays. The first element is the address and the second " -"element is the file to load at that address." $nl -"The filenames are relative to the path stored in the " { $link rom-root } -" variable. An exception is thrown if this variable is not set." -} -{ $examples - { $code "{ { HEX: 0000 \"invaders.rom\" } } load-rom*" } -} -{ $see-also load-rom } ; - -HELP: rom-root -{ $description -"Holds the path where the ROM files are stored. Used for expanding " -"the relative filenames passed to " { $link load-rom } " and " -{ $link load-rom* } "." -} -{ $see-also load-rom load-rom* } ; diff --git a/unmaintained/cpu/8080/emulator/emulator.factor b/unmaintained/cpu/8080/emulator/emulator.factor deleted file mode 100755 index 21392d43b1..0000000000 --- a/unmaintained/cpu/8080/emulator/emulator.factor +++ /dev/null @@ -1,1379 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: accessors kernel math sequences words arrays io io.files -math.parser assocs quotations parser lexer -peg peg.ebnf peg.parsers tools.time io.encodings.binary sequences.deep -symbols combinators fry namespaces ; -IN: cpu.8080.emulator - -TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; - -GENERIC: reset ( cpu -- ) -GENERIC: update-video ( value addr cpu -- ) -GENERIC: read-port ( port cpu -- byte ) -GENERIC: write-port ( value port cpu -- ) - -M: cpu update-video ( value addr cpu -- ) - 3drop ; - -M: cpu read-port ( port cpu -- byte ) - #! Read a byte from the hardware port. 'port' should - #! be an 8-bit value. - 2drop 0 ; - -M: cpu write-port ( value port cpu -- ) - #! Write a byte to the hardware port, where 'port' is - #! an 8-bit value. - 3drop ; - -: carry-flag HEX: 01 ; inline -: parity-flag HEX: 04 ; inline -: half-carry-flag HEX: 10 ; inline -: interrupt-flag HEX: 20 ; inline -: zero-flag HEX: 40 ; inline -: sign-flag HEX: 80 ; inline - -: >word< ( word -- byte byte ) - #! Explode a word into its two 8 bit values. - dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ; - -: cpu-af ( cpu -- word ) - #! Return the 16-bit pseudo register AF. - [ cpu-a 8 shift ] keep cpu-f bitor ; - -: set-cpu-af ( value cpu -- ) - #! Set the value of the 16-bit pseudo register AF - >r >word< r> tuck set-cpu-f set-cpu-a ; - -: cpu-bc ( cpu -- word ) - #! Return the 16-bit pseudo register BC. - [ cpu-b 8 shift ] keep cpu-c bitor ; - -: set-cpu-bc ( value cpu -- ) - #! Set the value of the 16-bit pseudo register BC - >r >word< r> tuck set-cpu-c set-cpu-b ; - -: cpu-de ( cpu -- word ) - #! Return the 16-bit pseudo register DE. - [ cpu-d 8 shift ] keep cpu-e bitor ; - -: set-cpu-de ( value cpu -- ) - #! Set the value of the 16-bit pseudo register DE - >r >word< r> tuck set-cpu-e set-cpu-d ; - -: cpu-hl ( cpu -- word ) - #! Return the 16-bit pseudo register HL. - [ cpu-h 8 shift ] keep cpu-l bitor ; - -: set-cpu-hl ( value cpu -- ) - #! Set the value of the 16-bit pseudo register HL - >r >word< r> tuck set-cpu-l set-cpu-h ; - -: flag-set? ( flag cpu -- bool ) - cpu-f bitand 0 = not ; - -: flag-clear? ( flag cpu -- bool ) - cpu-f bitand 0 = ; - -: flag-nz? ( cpu -- bool ) - #! Test flag status - cpu-f zero-flag bitand 0 = ; - -: flag-z? ( cpu -- bool ) - #! Test flag status - cpu-f zero-flag bitand 0 = not ; - -: flag-nc? ( cpu -- bool ) - #! Test flag status - cpu-f carry-flag bitand 0 = ; - -: flag-c? ( cpu -- bool ) - #! Test flag status - cpu-f carry-flag bitand 0 = not ; - -: flag-po? ( cpu -- bool ) - #! Test flag status - cpu-f parity-flag bitand 0 = ; - -: flag-pe? ( cpu -- bool ) - #! Test flag status - cpu-f parity-flag bitand 0 = not ; - -: flag-p? ( cpu -- bool ) - #! Test flag status - cpu-f sign-flag bitand 0 = ; - -: flag-m? ( cpu -- bool ) - #! Test flag status - cpu-f sign-flag bitand 0 = not ; - -: read-byte ( addr cpu -- byte ) - #! Read one byte from memory at the specified address. - #! The address is 16-bit, but if a value greater than - #! 0xFFFF is provided then return a default value. - over HEX: FFFF <= [ - cpu-ram nth - ] [ - 2drop HEX: FF - ] if ; - -: read-word ( addr cpu -- word ) - #! Read a 16-bit word from memory at the specified address. - #! The address is 16-bit, but if a value greater than - #! 0xFFFF is provided then return a default value. - [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ; - -: next-byte ( cpu -- byte ) - #! Return the value of the byte at PC, and increment PC. - [ cpu-pc ] keep - [ read-byte ] keep - [ cpu-pc 1 + ] keep - set-cpu-pc ; - -: next-word ( cpu -- word ) - #! Return the value of the word at PC, and increment PC. - [ cpu-pc ] keep - [ read-word ] keep - [ cpu-pc 2 + ] keep - set-cpu-pc ; - - -: write-byte ( value addr cpu -- ) - #! Write a byte to the specified memory address. - over dup HEX: 2000 < swap HEX: FFFF > or [ - 3drop - ] [ - 3dup cpu-ram set-nth - update-video - ] if ; - - -: write-word ( value addr cpu -- ) - #! Write a 16-bit word to the specified memory address. - >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ; - -: cpu-a-bitand ( quot cpu -- ) - #! A &= quot call - [ cpu-a swap call bitand ] keep set-cpu-a ; inline - -: cpu-a-bitor ( quot cpu -- ) - #! A |= quot call - [ cpu-a swap call bitor ] keep set-cpu-a ; inline - -: cpu-a-bitxor ( quot cpu -- ) - #! 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 - -: cpu-f-bitor ( quot cpu -- ) - #! F |= quot call - [ cpu-f swap call bitor ] keep set-cpu-f ; inline - -: cpu-f-bitxor ( quot cpu -- ) - #! F |= quot call - [ cpu-f swap call bitxor ] keep set-cpu-f ; inline - -: cpu-f-bitor= ( value cpu -- ) - #! cpu-f |= value - [ cpu-f bitor ] keep set-cpu-f ; - -: cpu-f-bitand= ( value cpu -- ) - #! 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 ; - -: set-flag ( cpu flag -- ) - swap cpu-f-bitor= ; - -: clear-flag ( cpu flag -- ) - bitnot HEX: FF bitand swap cpu-f-bitand= ; - -: update-zero-flag ( result cpu -- ) - #! If the result of an instruction has the value 0, this - #! flag is set, otherwise it is reset. - swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ; - -: update-sign-flag ( result cpu -- ) - #! If the most significant bit of the result - #! has the value 1 then the flag is set, otherwise - #! it is reset. - swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ; - -: update-parity-flag ( result cpu -- ) - #! If the modulo 2 sum of the bits of the result - #! is 0, (ie. if the result has even parity) this flag - #! is set, otherwise it is reset. - swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ; - -: update-carry-flag ( result cpu -- ) - #! If the instruction resulted in a carry (from addition) - #! or a borrow (from subtraction or a comparison) out of the - #! higher order bit, this flag is set, otherwise it is reset. - swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ; - -: update-half-carry-flag ( original change-by result cpu -- ) - #! If the instruction caused a carry out of bit 3 and into bit 4 of the - #! resulting value, the half carry flag is set, otherwise it is reset. - #! The 'original' is the original value of the register being changed. - #! 'change-by' is the amount it is being added or decremented by. - #! 'result' is the result of that change. - >r bitxor bitxor HEX: 10 bitand 0 = not r> - swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ; - -: update-flags ( result cpu -- ) - 2dup update-carry-flag - 2dup update-parity-flag - 2dup update-sign-flag - update-zero-flag ; - -: update-flags-no-carry ( result cpu -- ) - 2dup update-parity-flag - 2dup update-sign-flag - update-zero-flag ; - -: add-byte ( lhs rhs cpu -- result ) - #! Add rhs to lhs - >r 2dup + r> ! lhs rhs result cpu - [ update-flags ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: add-carry ( change-by result cpu -- change-by result ) - #! Add the effect of the carry flag to the result - flag-c? [ 1 + >r 1 + r> ] when ; - -: add-byte-with-carry ( lhs rhs cpu -- result ) - #! Add rhs to lhs plus carry. - >r 2dup + r> ! lhs rhs result cpu - [ add-carry ] keep - [ update-flags ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: sub-carry ( change-by result cpu -- change-by result ) - #! Subtract the effect of the carry flag from the result - flag-c? [ 1 - >r 1 - r> ] when ; - -: sub-byte ( lhs rhs cpu -- result ) - #! Subtract rhs from lhs - >r 2dup - r> - [ update-flags ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: sub-byte-with-carry ( lhs rhs cpu -- result ) - #! Subtract rhs from lhs and take carry into account - >r 2dup - r> - [ sub-carry ] keep - [ update-flags ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: inc-byte ( byte cpu -- result ) - #! Increment byte by one. Note that carry flag is not affected - #! by this operation. - >r 1 2dup + r> ! lhs rhs result cpu - [ update-flags-no-carry ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: dec-byte ( byte cpu -- result ) - #! Decrement byte by one. Note that carry flag is not affected - #! by this operation. - >r 1 2dup - r> ! lhs rhs result cpu - [ update-flags-no-carry ] 2keep - [ update-half-carry-flag ] 2keep - drop HEX: FF bitand ; - -: inc-word ( w cpu -- w ) - #! Increment word by one. Note that no flags are modified. - drop 1 + HEX: FFFF bitand ; - -: dec-word ( w cpu -- w ) - #! Decrement word by one. Note that no flags are modified. - drop 1 - HEX: FFFF bitand ; - -: add-word ( lhs rhs cpu -- result ) - #! 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. - >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ; - -: bit3or ( lhs rhs -- 0|1 ) - #! bitor bit 3 of the two numbers on the stack - BIN: 00001000 bitand -3 shift >r - BIN: 00001000 bitand -3 shift r> - bitor ; - -: and-byte ( lhs rhs cpu -- result ) - #! 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. - [ drop bit3or ] 3keep ! bit3or lhs rhs cpu - >r bitand r> [ update-flags ] 2keep - [ carry-flag clear-flag ] keep - rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if - HEX: FF bitand ; - -: xor-byte ( lhs rhs cpu -- result ) - #! Logically xor rhs to lhs. The carry and half-carry flags are cleared. - >r bitxor r> [ update-flags ] 2keep - [ half-carry-flag carry-flag bitor clear-flag ] keep - drop HEX: FF bitand ; - -: or-byte ( lhs rhs cpu -- result ) - #! Logically or rhs to lhs. The carry and half-carry flags are cleared. - >r bitor r> [ update-flags ] 2keep - [ half-carry-flag carry-flag bitor clear-flag ] keep - drop HEX: FF bitand ; - -: flags ( seq -- seq ) - [ 0 [ execute bitor ] reduce ] map ; - -: decrement-sp ( n cpu -- ) - #! Decrement the stackpointer by n. - [ cpu-sp ] keep - >r swap - r> set-cpu-sp ; - -: save-pc ( cpu -- ) - #! Save the value of the PC on the stack. - [ cpu-pc ] keep ! pc cpu - [ cpu-sp ] keep ! pc sp cpu - write-word ; - -: push-pc ( cpu -- ) - #! Push the value of the PC on the stack. - 2 over decrement-sp - save-pc ; - -: pop-pc ( cpu -- pc ) - #! Pop the value of the PC off the stack. - [ cpu-sp ] keep - [ read-word ] keep - -2 swap decrement-sp ; - -: push-sp ( value cpu -- ) - [ 2 swap decrement-sp ] keep - [ cpu-sp ] keep - write-word ; - -: pop-sp ( cpu -- value ) - [ cpu-sp ] keep - [ read-word ] keep - -2 swap decrement-sp ; - -: call-sub ( addr cpu -- ) - #! Call the address as a subroutine. - dup push-pc - >r HEX: FFFF bitand r> set-cpu-pc ; - -: ret-from-sub ( cpu -- ) - [ pop-pc ] keep set-cpu-pc ; - -: interrupt ( number cpu -- ) - #! Perform a hardware interrupt -! "***Interrupt: " write over 16 >base print - dup cpu-f interrupt-flag bitand 0 = not [ - dup push-pc - set-cpu-pc - ] [ - 2drop - ] if ; - -: inc-cycles ( n cpu -- ) - #! Increment the number of cpu cycles - [ cpu-cycles + ] keep set-cpu-cycles ; - -: instruction-cycles ( -- vector ) - #! Return a 256 element vector containing the cycles for - #! each opcode in the 8080 instruction set. - << 256 f parsed >> ; - -: not-implemented ( -- ) - drop ; - -: instructions ( -- vector ) - #! Return a 256 element vector containing the emulation words for - #! each opcode in the 8080 instruction set. - << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline - -: set-instruction ( quot n -- ) - tuck >r 2array r> instructions set-nth ; - -M: cpu reset ( cpu -- ) - #! Reset the CPU to its poweron state - [ 0 swap set-cpu-b ] keep - [ 0 swap set-cpu-c ] keep - [ 0 swap set-cpu-d ] keep - [ 0 swap set-cpu-e ] keep - [ 0 swap set-cpu-h ] keep - [ 0 swap set-cpu-l ] keep - [ 0 swap set-cpu-a ] keep - [ 0 swap set-cpu-f ] keep - [ 0 swap set-cpu-pc ] keep - [ HEX: F000 swap set-cpu-sp ] keep - [ HEX: FFFF 0 swap set-cpu-ram ] keep - [ f swap set-cpu-halted? ] keep - [ HEX: 10 swap set-cpu-last-interrupt ] keep - 0 swap set-cpu-cycles ; - -: ( -- cpu ) cpu new dup reset ; - -: (load-rom) ( n ram -- ) - read1 [ ! n ram ch - -rot [ set-nth ] 2keep >r 1 + r> (load-rom) - ] [ - 2drop - ] if* ; - - #! Reads the ROM from stdin and stores it in ROM from - #! offset n. -: load-rom ( filename cpu -- ) - #! Load the contents of the file into ROM. - #! (address 0x0000-0x1FFF). - cpu-ram swap binary [ - 0 swap (load-rom) - ] with-file-reader ; - -SYMBOL: rom-root - -: rom-dir ( -- string ) - rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ; - -: load-rom* ( seq cpu -- ) - #! 'seq' is an array of arrays. Each array contains - #! an address and filename of a ROM file. The ROM - #! file will be loaded at the specified address. This - #! file path shoul dbe relative to the '/roms' resource path. - rom-dir [ - cpu-ram [ - swap first2 rom-dir prepend-path binary [ - swap (load-rom) - ] with-file-reader - ] curry each - ] [ - ! - ! the ROM files. - "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw - ] if ; - -: read-instruction ( cpu -- word ) - #! Read the next instruction from the cpu's program - #! counter, and increment the program counter. - [ cpu-pc ] keep ! pc cpu - [ over 1 + swap set-cpu-pc ] keep - read-byte ; - -: get-cycles ( n -- opcode ) - #! Returns the cycles for the given instruction value. - #! If the opcode is not defined throw an error. - dup instruction-cycles nth [ - nip - ] [ - [ "Undefined 8080 opcode: " % number>string % ] "" make throw - ] if* ; - -: process-interrupts ( cpu -- ) - #! Process any hardware interrupts - [ cpu-cycles ] keep - over 16667 < [ - 2drop - ] [ - [ >r 16667 - r> set-cpu-cycles ] keep - dup cpu-last-interrupt HEX: 10 = [ - HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt - ] [ - HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt - ] if - ] if ; - -: peek-instruction ( cpu -- word ) - #! Return the next instruction from the cpu's program - #! counter, but don't increment the counter. - [ cpu-pc ] keep read-byte instructions nth first ; - -: 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 - [ " " write peek-instruction name>> write " " write ] keep - nl 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 - nl drop ; - -: register-lookup ( string -- vector ) - #! Given a string containing a register name, return a vector - #! where the 1st item is the getter and the 2nd is the setter - #! for that register. - H{ - { "A" { cpu-a set-cpu-a } } - { "B" { cpu-b set-cpu-b } } - { "C" { cpu-c set-cpu-c } } - { "D" { cpu-d set-cpu-d } } - { "E" { cpu-e set-cpu-e } } - { "H" { cpu-h set-cpu-h } } - { "L" { cpu-l set-cpu-l } } - { "AF" { cpu-af set-cpu-af } } - { "BC" { cpu-bc set-cpu-bc } } - { "DE" { cpu-de set-cpu-de } } - { "HL" { cpu-hl set-cpu-hl } } - { "SP" { cpu-sp set-cpu-sp } } - } at ; - - -: flag-lookup ( string -- vector ) - #! Given a string containing a flag name, return a vector - #! where the 1st item is a word that tests that flag. - H{ - { "NZ" { flag-nz? } } - { "NC" { flag-nc? } } - { "PO" { flag-po? } } - { "PE" { flag-pe? } } - { "Z" { flag-z? } } - { "C" { flag-c? } } - { "P" { flag-p? } } - { "M" { flag-m? } } - } at ; - -SYMBOLS: $1 $2 $3 $4 ; - -: replace-patterns ( vector tree -- tree ) - [ - { - { $1 [ first ] } - { $2 [ second ] } - { $3 [ third ] } - { $4 [ fourth ] } - [ nip ] - } case - ] with deep-map ; - -: (emulate-RST) ( n cpu -- ) - #! RST nn - [ cpu-sp 2 - dup ] keep ! sp sp cpu - [ set-cpu-sp ] keep ! sp cpu - [ cpu-pc ] keep ! sp pc cpu - swapd [ write-word ] keep ! cpu - >r 8 * r> set-cpu-pc ; - -: (emulate-CALL) ( cpu -- ) - #! 205 - CALL nn - [ next-word HEX: FFFF bitand ] keep ! addr cpu - [ cpu-sp 2 - dup ] keep ! addr sp sp cpu - [ set-cpu-sp ] keep ! addr sp cpu - [ cpu-pc ] keep ! addr sp pc cpu - swapd [ write-word ] keep ! addr cpu - set-cpu-pc ; - -: (emulate-RLCA) ( cpu -- ) - #! The content of the accumulator is rotated left - #! one position. The low order bit and the carry flag - #! are both set to the value shifd out of the high - #! order bit position. Only the carry flag is affected. - [ cpu-a -7 shift ] keep - over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - [ cpu-a 1 shift HEX: FF bitand ] keep - >r bitor r> set-cpu-a ; - -: (emulate-RRCA) ( cpu -- ) - #! The content of the accumulator is rotated right - #! one position. The high order bit and the carry flag - #! are both set to the value shifd out of the low - #! order bit position. Only the carry flag is affected. - [ cpu-a 1 bitand 7 shift ] keep - over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - [ cpu-a 254 bitand -1 shift ] keep - >r bitor r> set-cpu-a ; - -: (emulate-RLA) ( cpu -- ) - #! The content of the accumulator is rotated left - #! one position through the carry flag. The low - #! order bit is set equal to the carry flag and - #! the carry flag is set to the value shifd out - #! of the high order bit. Only the carry flag is - #! affected. - [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep - [ cpu-a 127 bitand 7 shift ] keep - dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - >r bitor r> set-cpu-a ; - -: (emulate-RRA) ( cpu -- ) - #! The content of the accumulator is rotated right - #! one position through the carry flag. The high order - #! bit is set to the carry flag and the carry flag is - #! set to the value shifd out of the low order bit. - #! Only the carry flag is affected. - [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep - [ cpu-a 254 bitand -1 shift ] keep - dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - >r bitor r> set-cpu-a ; - -: (emulate-CPL) ( cpu -- ) - #! The contents of the accumulator are complemented - #! (zero bits become one, one bits becomes zero). - #! No flags are affected. - HEX: FF swap cpu-a-bitxor= ; - -: (emulate-DAA) ( cpu -- ) - #! The eight bit number in the accumulator is - #! adjusted to form two four-bit binary-coded-decimal - #! digits. - [ - dup half-carry-flag swap flag-set? swap - cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if - ] keep - [ cpu-a + ] keep - [ update-flags ] 2keep - [ swap HEX: FF bitand swap set-cpu-a ] keep - [ - dup carry-flag swap flag-set? swap - cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if - ] keep - [ cpu-a + ] keep - [ update-flags ] 2keep - swap HEX: FF bitand swap set-cpu-a ; - -: patterns ( -- hashtable ) - #! table of code quotation patterns for each type of instruction. - H{ - { "NOP" [ drop ] } - { "RET-NN" [ ret-from-sub ] } - { "RST-0" [ 0 swap (emulate-RST) ] } - { "RST-8" [ 8 swap (emulate-RST) ] } - { "RST-10H" [ HEX: 10 swap (emulate-RST) ] } - { "RST-18H" [ HEX: 18 swap (emulate-RST) ] } - { "RST-20H" [ HEX: 20 swap (emulate-RST) ] } - { "RST-28H" [ HEX: 28 swap (emulate-RST) ] } - { "RST-30H" [ HEX: 30 swap (emulate-RST) ] } - { "RST-38H" [ HEX: 38 swap (emulate-RST) ] } - { "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-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] } - { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } - { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] } - { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] } - { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] } - { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] } - { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] } - { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] } - { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] } - { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] } - { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] } - { "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,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] } - { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } - { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } - { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } - { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] 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,(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-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] } - { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] } - { "CPL" [ (emulate-CPL) ] } - { "DAA" [ (emulate-DAA) ] } - { "RLA" [ (emulate-RLA) ] } - { "RRA" [ (emulate-RRA) ] } - { "CCF" [ carry-flag swap cpu-f-bitxor= ] } - { "SCF" [ carry-flag swap cpu-f-bitor= ] } - { "RLCA" [ (emulate-RLCA) ] } - { "RRCA" [ (emulate-RRCA) ] } - { "HALT" [ drop ] } - { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } - { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } - { "POP-RR" [ [ pop-sp ] keep $2 ] } - { "PUSH-RR" [ [ $1 ] keep push-sp ] } - { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } - { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } - { "INC-RR" [ [ $1 ] keep [ inc-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 ] } - { "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-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-(RR)" [ [ $1 ] keep set-cpu-pc ] } - { "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 ] } - { "LD-RR,NN" [ [ next-word ] keep $2 ] } - { "LD-RR,RR" [ [ $3 ] keep $2 ] } - { "LD-R,N" [ [ next-byte ] keep $2 ] } - { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } - { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } - { "LD-R,R" [ [ $3 ] keep $2 ] } - { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } - { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } - { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } - { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } - { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } - { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } - { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] } - { "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 ] } - } ; - -: 8-bit-registers ( -- parser ) - #! A parser for 8-bit registers. On a successfull parse the - #! parse tree contains a vector. The first item in the vector - #! is the getter word for that register with stack effect - #! ( cpu -- value ). The second item is the setter word with - #! stack effect ( value cpu -- ). - [[ register-lookup ]] - EBNF> ; - -: all-flags ( -- parser ) - #! A parser for 16-bit flags. - [[ flag-lookup ]] - EBNF> ; - -: 16-bit-registers ( -- parser ) - #! A parser for 16-bit registers. On a successfull parse the - #! parse tree contains a vector. The first item in the vector - #! is the getter word for that register with stack effect - #! ( cpu -- value ). The second item is the setter word with - #! stack effect ( value cpu -- ). - [[ register-lookup ]] - EBNF> ; - -: all-registers ( -- parser ) - #! Return a parser that can parse the format - #! for 8 bit or 16 bit registers. - [ 16-bit-registers , 8-bit-registers , ] choice* ; - -: indirect ( parser -- parser ) - #! Given a parser, return a parser which parses the original - #! wrapped in brackets, representing an indirect reference. - #! eg. BC -> (BC). The value of the original parser is left in - #! the parse tree. - "(" ")" surrounded-by ; - -: generate-instruction ( vector string -- quot ) - #! Generate the quotation for an instruction, given the instruction in - #! the 'string' and a vector containing the arguments for that instruction. - patterns at replace-patterns ; - -: simple-instruction ( token -- parser ) - #! Return a parser for then instruction identified by the token. - #! The parser return parses the token only and expects no additional - #! arguments to the instruction. - token [ '[ { } , generate-instruction ] ] action ; - -: complex-instruction ( type token -- parser ) - #! Return a parser for an instruction identified by the token. - #! The instruction is expected to take additional arguments by - #! being combined with other parsers. Then 'type' is used for a lookup - #! in a pattern hashtable to return the instruction quotation pattern. - token swap [ nip '[ , generate-instruction ] ] curry action ; - -: no-params ( ast -- ast ) - first { } swap curry ; - -: one-param ( ast -- ast ) - first2 swap curry ; - -: two-params ( ast -- ast ) - first3 append swap curry ; - -: NOP-instruction ( -- parser ) - "NOP" simple-instruction ; - -: RET-NN-instruction ( -- parser ) - [ - "RET-NN" "RET" complex-instruction , - "nn" token sp hide , - ] seq* [ no-params ] action ; - -: RST-0-instruction ( -- parser ) - [ - "RST-0" "RST" complex-instruction , - "0" token sp hide , - ] seq* [ no-params ] action ; - -: RST-8-instruction ( -- parser ) - [ - "RST-8" "RST" complex-instruction , - "8" token sp hide , - ] seq* [ no-params ] action ; - -: RST-10H-instruction ( -- parser ) - [ - "RST-10H" "RST" complex-instruction , - "10H" token sp hide , - ] seq* [ no-params ] action ; - -: RST-18H-instruction ( -- parser ) - [ - "RST-18H" "RST" complex-instruction , - "18H" token sp hide , - ] seq* [ no-params ] action ; - -: RST-20H-instruction ( -- parser ) - [ - "RST-20H" "RST" complex-instruction , - "20H" token sp hide , - ] seq* [ no-params ] action ; - -: RST-28H-instruction ( -- parser ) - [ - "RST-28H" "RST" complex-instruction , - "28H" token sp hide , - ] seq* [ no-params ] action ; - -: RST-30H-instruction ( -- parser ) - [ - "RST-30H" "RST" complex-instruction , - "30H" token sp hide , - ] seq* [ no-params ] action ; - -: RST-38H-instruction ( -- parser ) - [ - "RST-38H" "RST" complex-instruction , - "38H" token sp hide , - ] seq* [ no-params ] action ; - -: JP-NN-instruction ( -- parser ) - [ - "JP-NN" "JP" complex-instruction , - "nn" token sp hide , - ] seq* [ no-params ] action ; - -: JP-F|FF,NN-instruction ( -- parser ) - [ - "JP-F|FF,NN" "JP" complex-instruction , - all-flags sp , - ",nn" token hide , - ] seq* [ one-param ] action ; - -: JP-(RR)-instruction ( -- parser ) - [ - "JP-(RR)" "JP" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: CALL-NN-instruction ( -- parser ) - [ - "CALL-NN" "CALL" complex-instruction , - "nn" token sp hide , - ] seq* [ no-params ] action ; - -: CALL-F|FF,NN-instruction ( -- parser ) - [ - "CALL-F|FF,NN" "CALL" complex-instruction , - all-flags sp , - ",nn" token hide , - ] seq* [ one-param ] action ; - -: RLCA-instruction ( -- parser ) - "RLCA" simple-instruction ; - -: RRCA-instruction ( -- parser ) - "RRCA" simple-instruction ; - -: HALT-instruction ( -- parser ) - "HALT" simple-instruction ; - -: DI-instruction ( -- parser ) - "DI" simple-instruction ; - -: EI-instruction ( -- parser ) - "EI" simple-instruction ; - -: CPL-instruction ( -- parser ) - "CPL" simple-instruction ; - -: CCF-instruction ( -- parser ) - "CCF" simple-instruction ; - -: SCF-instruction ( -- parser ) - "SCF" simple-instruction ; - -: DAA-instruction ( -- parser ) - "DAA" simple-instruction ; - -: RLA-instruction ( -- parser ) - "RLA" simple-instruction ; - -: RRA-instruction ( -- parser ) - "RRA" simple-instruction ; - -: DEC-R-instruction ( -- parser ) - [ - "DEC-R" "DEC" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: DEC-RR-instruction ( -- parser ) - [ - "DEC-RR" "DEC" complex-instruction , - 16-bit-registers sp , - ] seq* [ one-param ] action ; - -: DEC-(RR)-instruction ( -- parser ) - [ - "DEC-(RR)" "DEC" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: POP-RR-instruction ( -- parser ) - [ - "POP-RR" "POP" complex-instruction , - all-registers sp , - ] seq* [ one-param ] action ; - -: PUSH-RR-instruction ( -- parser ) - [ - "PUSH-RR" "PUSH" complex-instruction , - all-registers sp , - ] seq* [ one-param ] action ; - -: INC-R-instruction ( -- parser ) - [ - "INC-R" "INC" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: INC-RR-instruction ( -- parser ) - [ - "INC-RR" "INC" complex-instruction , - 16-bit-registers sp , - ] seq* [ one-param ] action ; - -: INC-(RR)-instruction ( -- parser ) - [ - "INC-(RR)" "INC" complex-instruction , - all-registers indirect sp , - ] seq* [ one-param ] action ; - -: RET-F|FF-instruction ( -- parser ) - [ - "RET-F|FF" "RET" complex-instruction , - all-flags sp , - ] seq* [ one-param ] action ; - -: AND-N-instruction ( -- parser ) - [ - "AND-N" "AND" complex-instruction , - "n" token sp hide , - ] seq* [ no-params ] action ; - -: AND-R-instruction ( -- parser ) - [ - "AND-R" "AND" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: AND-(RR)-instruction ( -- parser ) - [ - "AND-(RR)" "AND" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: XOR-N-instruction ( -- parser ) - [ - "XOR-N" "XOR" complex-instruction , - "n" token sp hide , - ] seq* [ no-params ] action ; - -: XOR-R-instruction ( -- parser ) - [ - "XOR-R" "XOR" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: XOR-(RR)-instruction ( -- parser ) - [ - "XOR-(RR)" "XOR" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: OR-N-instruction ( -- parser ) - [ - "OR-N" "OR" complex-instruction , - "n" token sp hide , - ] seq* [ no-params ] action ; - -: OR-R-instruction ( -- parser ) - [ - "OR-R" "OR" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: OR-(RR)-instruction ( -- parser ) - [ - "OR-(RR)" "OR" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: CP-N-instruction ( -- parser ) - [ - "CP-N" "CP" complex-instruction , - "n" token sp hide , - ] seq* [ no-params ] action ; - -: CP-R-instruction ( -- parser ) - [ - "CP-R" "CP" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: CP-(RR)-instruction ( -- parser ) - [ - "CP-(RR)" "CP" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: ADC-R,N-instruction ( -- parser ) - [ - "ADC-R,N" "ADC" complex-instruction , - 8-bit-registers sp , - ",n" token hide , - ] seq* [ one-param ] action ; - -: ADC-R,R-instruction ( -- parser ) - [ - "ADC-R,R" "ADC" complex-instruction , - 8-bit-registers sp , - "," token hide , - 8-bit-registers , - ] seq* [ two-params ] action ; - -: ADC-R,(RR)-instruction ( -- parser ) - [ - "ADC-R,(RR)" "ADC" complex-instruction , - 8-bit-registers sp , - "," token hide , - 16-bit-registers indirect , - ] seq* [ two-params ] action ; - -: SBC-R,N-instruction ( -- parser ) - [ - "SBC-R,N" "SBC" complex-instruction , - 8-bit-registers sp , - ",n" token hide , - ] seq* [ one-param ] action ; - -: SBC-R,R-instruction ( -- parser ) - [ - "SBC-R,R" "SBC" complex-instruction , - 8-bit-registers sp , - "," token hide , - 8-bit-registers , - ] seq* [ two-params ] action ; - -: SBC-R,(RR)-instruction ( -- parser ) - [ - "SBC-R,(RR)" "SBC" complex-instruction , - 8-bit-registers sp , - "," token hide , - 16-bit-registers indirect , - ] seq* [ two-params ] action ; - -: SUB-R-instruction ( -- parser ) - [ - "SUB-R" "SUB" complex-instruction , - 8-bit-registers sp , - ] seq* [ one-param ] action ; - -: SUB-(RR)-instruction ( -- parser ) - [ - "SUB-(RR)" "SUB" complex-instruction , - 16-bit-registers indirect sp , - ] seq* [ one-param ] action ; - -: SUB-N-instruction ( -- parser ) - [ - "SUB-N" "SUB" complex-instruction , - "n" token sp hide , - ] seq* [ no-params ] action ; - -: ADD-R,N-instruction ( -- parser ) - [ - "ADD-R,N" "ADD" complex-instruction , - 8-bit-registers sp , - ",n" token hide , - ] seq* [ one-param ] action ; - -: ADD-R,R-instruction ( -- parser ) - [ - "ADD-R,R" "ADD" complex-instruction , - 8-bit-registers sp , - "," token hide , - 8-bit-registers , - ] seq* [ two-params ] action ; - -: ADD-RR,RR-instruction ( -- parser ) - [ - "ADD-RR,RR" "ADD" complex-instruction , - 16-bit-registers sp , - "," token hide , - 16-bit-registers , - ] seq* [ two-params ] action ; - -: ADD-R,(RR)-instruction ( -- parser ) - [ - "ADD-R,(RR)" "ADD" complex-instruction , - 8-bit-registers sp , - "," token hide , - 16-bit-registers indirect , - ] seq* [ two-params ] action ; - -: LD-RR,NN-instruction ( -- parser ) - #! LD BC,nn - [ - "LD-RR,NN" "LD" complex-instruction , - 16-bit-registers sp , - ",nn" token hide , - ] seq* [ one-param ] action ; - -: LD-R,N-instruction ( -- parser ) - #! LD B,n - [ - "LD-R,N" "LD" complex-instruction , - 8-bit-registers sp , - ",n" token hide , - ] seq* [ one-param ] action ; - -: LD-(RR),N-instruction ( -- parser ) - [ - "LD-(RR),N" "LD" complex-instruction , - 16-bit-registers indirect sp , - ",n" token hide , - ] seq* [ one-param ] action ; - -: LD-(RR),R-instruction ( -- parser ) - #! LD (BC),A - [ - "LD-(RR),R" "LD" complex-instruction , - 16-bit-registers indirect sp , - "," token hide , - 8-bit-registers , - ] seq* [ two-params ] action ; - -: LD-R,R-instruction ( -- parser ) - [ - "LD-R,R" "LD" complex-instruction , - 8-bit-registers sp , - "," token hide , - 8-bit-registers , - ] seq* [ two-params ] action ; - -: LD-RR,RR-instruction ( -- parser ) - [ - "LD-RR,RR" "LD" complex-instruction , - 16-bit-registers sp , - "," token hide , - 16-bit-registers , - ] seq* [ two-params ] action ; - -: LD-R,(RR)-instruction ( -- parser ) - [ - "LD-R,(RR)" "LD" complex-instruction , - 8-bit-registers sp , - "," token hide , - 16-bit-registers indirect , - ] seq* [ two-params ] action ; - -: LD-(NN),RR-instruction ( -- parser ) - [ - "LD-(NN),RR" "LD" complex-instruction , - "nn" token indirect sp hide , - "," token hide , - 16-bit-registers , - ] seq* [ one-param ] action ; - -: LD-(NN),R-instruction ( -- parser ) - [ - "LD-(NN),R" "LD" complex-instruction , - "nn" token indirect sp hide , - "," token hide , - 8-bit-registers , - ] seq* [ one-param ] action ; - -: LD-RR,(NN)-instruction ( -- parser ) - [ - "LD-RR,(NN)" "LD" complex-instruction , - 16-bit-registers sp , - "," token hide , - "nn" token indirect hide , - ] seq* [ one-param ] action ; - -: LD-R,(NN)-instruction ( -- parser ) - [ - "LD-R,(NN)" "LD" complex-instruction , - 8-bit-registers sp , - "," token hide , - "nn" token indirect hide , - ] seq* [ one-param ] action ; - -: OUT-(N),R-instruction ( -- parser ) - [ - "OUT-(N),R" "OUT" complex-instruction , - "n" token indirect sp hide , - "," token hide , - 8-bit-registers , - ] seq* [ one-param ] action ; - -: IN-R,(N)-instruction ( -- parser ) - [ - "IN-R,(N)" "IN" complex-instruction , - 8-bit-registers sp , - "," token hide , - "n" token indirect hide , - ] seq* [ one-param ] action ; - -: EX-(RR),RR-instruction ( -- parser ) - [ - "EX-(RR),RR" "EX" complex-instruction , - 16-bit-registers indirect sp , - "," token hide , - 16-bit-registers , - ] seq* [ two-params ] action ; - -: EX-RR,RR-instruction ( -- parser ) - [ - "EX-RR,RR" "EX" complex-instruction , - 16-bit-registers sp , - "," token hide , - 16-bit-registers , - ] seq* [ two-params ] action ; - -: 8080-generator-parser ( -- parser ) - [ - NOP-instruction , - RST-0-instruction , - RST-8-instruction , - RST-10H-instruction , - RST-18H-instruction , - RST-20H-instruction , - RST-28H-instruction , - RST-30H-instruction , - RST-38H-instruction , - JP-F|FF,NN-instruction , - JP-NN-instruction , - JP-(RR)-instruction , - CALL-F|FF,NN-instruction , - CALL-NN-instruction , - CPL-instruction , - CCF-instruction , - SCF-instruction , - DAA-instruction , - RLA-instruction , - RRA-instruction , - RLCA-instruction , - RRCA-instruction , - HALT-instruction , - DI-instruction , - EI-instruction , - AND-N-instruction , - AND-R-instruction , - AND-(RR)-instruction , - XOR-N-instruction , - XOR-R-instruction , - XOR-(RR)-instruction , - OR-N-instruction , - OR-R-instruction , - OR-(RR)-instruction , - CP-N-instruction , - CP-R-instruction , - CP-(RR)-instruction , - DEC-RR-instruction , - DEC-R-instruction , - DEC-(RR)-instruction , - POP-RR-instruction , - PUSH-RR-instruction , - INC-RR-instruction , - INC-R-instruction , - INC-(RR)-instruction , - LD-RR,NN-instruction , - LD-RR,RR-instruction , - LD-R,N-instruction , - LD-R,R-instruction , - LD-(RR),N-instruction , - LD-(RR),R-instruction , - LD-R,(RR)-instruction , - LD-(NN),RR-instruction , - LD-(NN),R-instruction , - LD-RR,(NN)-instruction , - LD-R,(NN)-instruction , - ADC-R,(RR)-instruction , - ADC-R,N-instruction , - ADC-R,R-instruction , - ADD-R,N-instruction , - ADD-R,(RR)-instruction , - ADD-R,R-instruction , - ADD-RR,RR-instruction , - SBC-R,N-instruction , - SBC-R,R-instruction , - SBC-R,(RR)-instruction , - SUB-R-instruction , - SUB-(RR)-instruction , - SUB-N-instruction , - RET-F|FF-instruction , - RET-NN-instruction , - OUT-(N),R-instruction , - IN-R,(N)-instruction , - EX-(RR),RR-instruction , - EX-RR,RR-instruction , - ] choice* [ call ] action ; - -: instruction-quotations ( string -- emulate-quot ) - #! Given an instruction string, return the emulation quotation for - #! it. This will later be expanded to produce the disassembly and - #! assembly quotations. - 8080-generator-parser parse ; - -SYMBOL: last-instruction -SYMBOL: last-opcode - -: parse-instructions ( list -- emulate-quot ) - #! Process the list of strings, which should make - #! up an 8080 instruction, and output a quotation - #! that would implement that instruction. - dup " " join instruction-quotations - >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at - r> (( cpu -- )) define-declared ; - -: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing - -: cycles ( -- ) - #! Set the number of cycles for the last instruction that was defined. - scan string>number last-opcode global at instruction-cycles set-nth ; parsing - -: opcode ( -- ) - #! Set the opcode number for the last instruction that was defined. - last-instruction global at 1quotation scan 16 base> - dup last-opcode global set-at set-instruction ; parsing - diff --git a/unmaintained/cpu/8080/emulator/summary.txt b/unmaintained/cpu/8080/emulator/summary.txt deleted file mode 100644 index 083492dfc4..0000000000 --- a/unmaintained/cpu/8080/emulator/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Intel 8080 CPU Emulator diff --git a/unmaintained/cpu/8080/emulator/tags.txt b/unmaintained/cpu/8080/emulator/tags.txt deleted file mode 100644 index ff94650b8e..0000000000 --- a/unmaintained/cpu/8080/emulator/tags.txt +++ /dev/null @@ -1 +0,0 @@ -emulators diff --git a/unmaintained/cpu/8080/summary.txt b/unmaintained/cpu/8080/summary.txt deleted file mode 100644 index 083492dfc4..0000000000 --- a/unmaintained/cpu/8080/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Intel 8080 CPU Emulator diff --git a/unmaintained/cpu/8080/tags.txt b/unmaintained/cpu/8080/tags.txt deleted file mode 100644 index ff94650b8e..0000000000 --- a/unmaintained/cpu/8080/tags.txt +++ /dev/null @@ -1 +0,0 @@ -emulators diff --git a/unmaintained/cpu/8080/test/test.factor b/unmaintained/cpu/8080/test/test.factor deleted file mode 100755 index f88db2935f..0000000000 --- a/unmaintained/cpu/8080/test/test.factor +++ /dev/null @@ -1,51 +0,0 @@ -USING: kernel cpu.8080 cpu.8080.emulator math math io -tools.time combinators sequences io.files io.encodings.ascii ; -IN: cpu.8080.test - -: step ( cpu -- ) - #! Run a single 8080 instruction - [ read-instruction ] keep ! n cpu - over get-cycles over inc-cycles - [ swap instructions case ] keep - [ cpu-pc HEX: FFFF bitand ] keep - [ set-cpu-pc ] keep - process-interrupts ; - - -: test-step ( cpu -- cpu ) - [ step ] keep dup cpu. ; - -: test-cpu ( -- cpu ) - "invaders.rom" over load-rom dup cpu. ; - -: test-n ( n -- ) - test-cpu swap [ test-step ] times drop ; - -: run-n ( cpu n -- cpu ) - [ dup step ] times ; - -: each-8bit ( n quot -- ) - 8 -rot [ >r bit? r> call ] 2curry each ; inline - -: >ppm ( cpu filename -- cpu ) - #! Dump the current screen image to a ppm image file with the given name. - ascii [ - "P3" print - "256 224" print - "1" print - 224 [ - 32 [ - over 32 * over + HEX: 2400 + ! cpu h w addr - >r pick r> swap cpu-ram nth [ - 0 = [ - " 0 0 0" write - ] [ - " 1 1 1" write - ] if - ] each-8bit drop - ] each drop nl - ] each - ] with-file-writer ; - -: time-test ( -- ) - test-cpu [ 1000000 run-n drop ] time ; From d62714e403dbc7f542fd95eebcf36762c4bbfe85 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 15 Oct 2009 18:08:30 +1300 Subject: [PATCH 2/4] Fix bitrot in space-invaders and cpu.8080 vocabs --- extra/cpu/8080/8080-docs.factor | 16 + extra/cpu/8080/8080.factor | 251 +++ .../cpu/8080}/authors.txt | 0 extra/cpu/8080/emulator/authors.txt | 1 + extra/cpu/8080/emulator/emulator-docs.factor | 36 + extra/cpu/8080/emulator/emulator.factor | 1407 +++++++++++++++++ extra/cpu/8080/emulator/summary.txt | 1 + extra/cpu/8080/emulator/tags.txt | 1 + extra/cpu/8080/summary.txt | 1 + extra/cpu/8080/tags.txt | 1 + extra/cpu/8080/test/test.factor | 70 + extra/space-invaders/authors.txt | 1 + .../space-invaders/resources/BaseHit.wav | Bin .../space-invaders/resources/InvHit.Wav | Bin .../space-invaders/resources/Shot.wav | Bin .../space-invaders/resources/Ufo.wav | Bin .../space-invaders/resources/UfoHit.wav | Bin .../space-invaders/resources/Walk1.wav | Bin .../space-invaders/resources/Walk2.wav | Bin .../space-invaders/resources/Walk3.wav | Bin .../space-invaders/resources/Walk4.wav | Bin .../space-invaders/space-invaders-docs.factor | 0 .../space-invaders/space-invaders.factor | 264 ++-- .../space-invaders/summary.txt | 0 .../space-invaders/tags.txt | 0 25 files changed, 1931 insertions(+), 119 deletions(-) create mode 100644 extra/cpu/8080/8080-docs.factor create mode 100755 extra/cpu/8080/8080.factor rename {unmaintained/space-invaders => extra/cpu/8080}/authors.txt (100%) create mode 100644 extra/cpu/8080/emulator/authors.txt create mode 100644 extra/cpu/8080/emulator/emulator-docs.factor create mode 100755 extra/cpu/8080/emulator/emulator.factor create mode 100644 extra/cpu/8080/emulator/summary.txt create mode 100644 extra/cpu/8080/emulator/tags.txt create mode 100644 extra/cpu/8080/summary.txt create mode 100644 extra/cpu/8080/tags.txt create mode 100755 extra/cpu/8080/test/test.factor create mode 100644 extra/space-invaders/authors.txt rename {unmaintained => extra}/space-invaders/resources/BaseHit.wav (100%) rename {unmaintained => extra}/space-invaders/resources/InvHit.Wav (100%) rename {unmaintained => extra}/space-invaders/resources/Shot.wav (100%) rename {unmaintained => extra}/space-invaders/resources/Ufo.wav (100%) rename {unmaintained => extra}/space-invaders/resources/UfoHit.wav (100%) rename {unmaintained => extra}/space-invaders/resources/Walk1.wav (100%) rename {unmaintained => extra}/space-invaders/resources/Walk2.wav (100%) rename {unmaintained => extra}/space-invaders/resources/Walk3.wav (100%) rename {unmaintained => extra}/space-invaders/resources/Walk4.wav (100%) rename {unmaintained => extra}/space-invaders/space-invaders-docs.factor (100%) rename {unmaintained => extra}/space-invaders/space-invaders.factor (54%) rename {unmaintained => extra}/space-invaders/summary.txt (100%) rename {unmaintained => extra}/space-invaders/tags.txt (100%) diff --git a/extra/cpu/8080/8080-docs.factor b/extra/cpu/8080/8080-docs.factor new file mode 100644 index 0000000000..48b68360cb --- /dev/null +++ b/extra/cpu/8080/8080-docs.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax sequences strings cpu.8080.emulator ; +IN: cpu.8080 + + +ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator" +"The cpu-8080 library provides an emulator for the Intel 8080 CPU" +" instruction set. It is complete enough to emulate some 8080" +" based arcade games." $nl +"The emulated CPU can load 'ROM' files from disk using the " +{ $link load-rom } " and " { $link load-rom* } " words. These expect " +"the " { $link rom-root } " variable to be set to the path " +"containing the ROM file's." ; + +ABOUT: { "cpu-8080" "cpu-8080" } diff --git a/extra/cpu/8080/8080.factor b/extra/cpu/8080/8080.factor new file mode 100755 index 0000000000..45a5129a72 --- /dev/null +++ b/extra/cpu/8080/8080.factor @@ -0,0 +1,251 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: cpu.8080.emulator tools.time ; +IN: cpu.8080 + +INSTRUCTION: NOP ; opcode 00 cycles 04 +INSTRUCTION: LD BC,nn ; opcode 01 cycles 10 +INSTRUCTION: LD (BC),A ; opcode 02 cycles 07 +INSTRUCTION: INC BC ; opcode 03 cycles 06 +INSTRUCTION: INC B ; opcode 04 cycles 05 +INSTRUCTION: DEC B ; opcode 05 cycles 05 +INSTRUCTION: LD B,n ; opcode 06 cycles 07 +INSTRUCTION: RLCA ; opcode 07 cycles 04 +! INSTRUCTION: NOP ; opcode 08 cycles 04 +INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11 +INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07 +INSTRUCTION: DEC BC ; opcode 0B cycles 06 +INSTRUCTION: INC C ; opcode 0C cycles 05 +INSTRUCTION: DEC C ; opcode 0D cycles 05 +INSTRUCTION: LD C,n ; opcode 0E cycles 07 +INSTRUCTION: RRCA ; opcode 0F cycles 04 +INSTRUCTION: LD DE,nn ; opcode 11 cycles 10 +INSTRUCTION: LD (DE),A ; opcode 12 cycles 07 +INSTRUCTION: INC DE ; opcode 13 cycles 06 +INSTRUCTION: INC D ; opcode 14 cycles 05 +INSTRUCTION: DEC D ; opcode 15 cycles 05 +INSTRUCTION: LD D,n ; opcode 16 cycles 07 +INSTRUCTION: RLA ; opcode 17 cycles 04 +INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11 +INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07 +INSTRUCTION: DEC DE ; opcode 1B cycles 06 +INSTRUCTION: INC E ; opcode 1C cycles 05 +INSTRUCTION: DEC E ; opcode 1D cycles 05 +INSTRUCTION: LD E,n ; opcode 1E cycles 07 +INSTRUCTION: RRA ; opcode 1F cycles 04 +INSTRUCTION: LD HL,nn ; opcode 21 cycles 10 +INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16 +INSTRUCTION: INC HL ; opcode 23 cycles 06 +INSTRUCTION: INC H ; opcode 24 cycles 05 +INSTRUCTION: DEC H ; opcode 25 cycles 05 +INSTRUCTION: LD H,n ; opcode 26 cycles 07 +INSTRUCTION: DAA ; opcode 27 cycles 04 +INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11 +INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16 +INSTRUCTION: DEC HL ; opcode 2B cycles 06 +INSTRUCTION: INC L ; opcode 2C cycles 05 +INSTRUCTION: DEC L ; opcode 2D cycles 05 +INSTRUCTION: LD L,n ; opcode 2E cycles 07 +INSTRUCTION: CPL ; opcode 2F cycles 04 +INSTRUCTION: LD SP,nn ; opcode 31 cycles 10 +INSTRUCTION: LD (nn),A ; opcode 32 cycles 13 +INSTRUCTION: INC SP ; opcode 33 cycles 06 +INSTRUCTION: INC (HL) ; opcode 34 cycles 10 +INSTRUCTION: DEC (HL) ; opcode 35 cycles 10 +INSTRUCTION: LD (HL),n ; opcode 36 cycles 10 +INSTRUCTION: SCF ; opcode 37 cycles 04 +INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11 +INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13 +INSTRUCTION: DEC SP ; opcode 3B cycles 06 +INSTRUCTION: INC A ; opcode 3C cycles 05 +INSTRUCTION: DEC A ; opcode 3D cycles 05 +INSTRUCTION: LD A,n ; opcode 3E cycles 07 +INSTRUCTION: CCF ; opcode 3F cycles 04 +INSTRUCTION: LD B,B ; opcode 40 cycles 05 +INSTRUCTION: LD B,C ; opcode 41 cycles 05 +INSTRUCTION: LD B,D ; opcode 42 cycles 05 +INSTRUCTION: LD B,E ; opcode 43 cycles 05 +INSTRUCTION: LD B,H ; opcode 44 cycles 05 +INSTRUCTION: LD B,L ; opcode 45 cycles 05 +INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07 +INSTRUCTION: LD B,A ; opcode 47 cycles 05 +INSTRUCTION: LD C,B ; opcode 48 cycles 05 +INSTRUCTION: LD C,C ; opcode 49 cycles 05 +INSTRUCTION: LD C,D ; opcode 4A cycles 05 +INSTRUCTION: LD C,E ; opcode 4B cycles 05 +INSTRUCTION: LD C,H ; opcode 4C cycles 05 +INSTRUCTION: LD C,L ; opcode 4D cycles 05 +INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07 +INSTRUCTION: LD C,A ; opcode 4F cycles 05 +INSTRUCTION: LD D,B ; opcode 50 cycles 05 +INSTRUCTION: LD D,C ; opcode 51 cycles 05 +INSTRUCTION: LD D,D ; opcode 52 cycles 05 +INSTRUCTION: LD D,E ; opcode 53 cycles 05 +INSTRUCTION: LD D,H ; opcode 54 cycles 05 +INSTRUCTION: LD D,L ; opcode 55 cycles 05 +INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07 +INSTRUCTION: LD D,A ; opcode 57 cycles 05 +INSTRUCTION: LD E,B ; opcode 58 cycles 05 +INSTRUCTION: LD E,C ; opcode 59 cycles 05 +INSTRUCTION: LD E,D ; opcode 5A cycles 05 +INSTRUCTION: LD E,E ; opcode 5B cycles 05 +INSTRUCTION: LD E,H ; opcode 5C cycles 05 +INSTRUCTION: LD E,L ; opcode 5D cycles 05 +INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07 +INSTRUCTION: LD E,A ; opcode 5F cycles 05 +INSTRUCTION: LD H,B ; opcode 60 cycles 05 +INSTRUCTION: LD H,C ; opcode 61 cycles 05 +INSTRUCTION: LD H,D ; opcode 62 cycles 05 +INSTRUCTION: LD H,E ; opcode 63 cycles 05 +INSTRUCTION: LD H,H ; opcode 64 cycles 05 +INSTRUCTION: LD H,L ; opcode 65 cycles 05 +INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07 +INSTRUCTION: LD H,A ; opcode 67 cycles 05 +INSTRUCTION: LD L,B ; opcode 68 cycles 05 +INSTRUCTION: LD L,C ; opcode 69 cycles 05 +INSTRUCTION: LD L,D ; opcode 6A cycles 05 +INSTRUCTION: LD L,E ; opcode 6B cycles 05 +INSTRUCTION: LD L,H ; opcode 6C cycles 05 +INSTRUCTION: LD L,L ; opcode 6D cycles 05 +INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07 +INSTRUCTION: LD L,A ; opcode 6F cycles 05 +INSTRUCTION: LD (HL),B ; opcode 70 cycles 07 +INSTRUCTION: LD (HL),C ; opcode 71 cycles 07 +INSTRUCTION: LD (HL),D ; opcode 72 cycles 07 +INSTRUCTION: LD (HL),E ; opcode 73 cycles 07 +INSTRUCTION: LD (HL),H ; opcode 74 cycles 07 +INSTRUCTION: LD (HL),L ; opcode 75 cycles 07 +INSTRUCTION: HALT ; opcode 76 cycles 07 +INSTRUCTION: LD (HL),A ; opcode 77 cycles 07 +INSTRUCTION: LD A,B ; opcode 78 cycles 05 +INSTRUCTION: LD A,C ; opcode 79 cycles 05 +INSTRUCTION: LD A,D ; opcode 7A cycles 05 +INSTRUCTION: LD A,E ; opcode 7B cycles 05 +INSTRUCTION: LD A,H ; opcode 7C cycles 05 +INSTRUCTION: LD A,L ; opcode 7D cycles 05 +INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07 +INSTRUCTION: LD A,A ; opcode 7F cycles 05 +INSTRUCTION: ADD A,B ; opcode 80 cycles 04 +INSTRUCTION: ADD A,C ; opcode 81 cycles 04 +INSTRUCTION: ADD A,D ; opcode 82 cycles 04 +INSTRUCTION: ADD A,E ; opcode 83 cycles 04 +INSTRUCTION: ADD A,H ; opcode 84 cycles 04 +INSTRUCTION: ADD A,L ; opcode 85 cycles 04 +INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07 +INSTRUCTION: ADD A,A ; opcode 87 cycles 04 +INSTRUCTION: ADC A,B ; opcode 88 cycles 04 +INSTRUCTION: ADC A,C ; opcode 89 cycles 04 +INSTRUCTION: ADC A,D ; opcode 8A cycles 04 +INSTRUCTION: ADC A,E ; opcode 8B cycles 04 +INSTRUCTION: ADC A,H ; opcode 8C cycles 04 +INSTRUCTION: ADC A,L ; opcode 8D cycles 04 +INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07 +INSTRUCTION: ADC A,A ; opcode 8F cycles 04 +INSTRUCTION: SUB B ; opcode 90 cycles 04 +INSTRUCTION: SUB C ; opcode 91 cycles 04 +INSTRUCTION: SUB D ; opcode 92 cycles 04 +INSTRUCTION: SUB E ; opcode 93 cycles 04 +INSTRUCTION: SUB H ; opcode 94 cycles 04 +INSTRUCTION: SUB L ; opcode 95 cycles 04 +INSTRUCTION: SUB (HL) ; opcode 96 cycles 07 +INSTRUCTION: SUB A ; opcode 97 cycles 04 +INSTRUCTION: SBC A,B ; opcode 98 cycles 04 +INSTRUCTION: SBC A,C ; opcode 99 cycles 04 +INSTRUCTION: SBC A,D ; opcode 9A cycles 04 +INSTRUCTION: SBC A,E ; opcode 9B cycles 04 +INSTRUCTION: SBC A,H ; opcode 9C cycles 04 +INSTRUCTION: SBC A,L ; opcode 9D cycles 04 +INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07 +INSTRUCTION: SBC A,A ; opcode 9F cycles 04 +INSTRUCTION: AND B ; opcode A0 cycles 04 +INSTRUCTION: AND C ; opcode A1 cycles 04 +INSTRUCTION: AND D ; opcode A2 cycles 04 +INSTRUCTION: AND E ; opcode A3 cycles 04 +INSTRUCTION: AND H ; opcode A4 cycles 04 +INSTRUCTION: AND L ; opcode A5 cycles 04 +INSTRUCTION: AND (HL) ; opcode A6 cycles 07 +INSTRUCTION: AND A ; opcode A7 cycles 04 +INSTRUCTION: XOR B ; opcode A8 cycles 04 +INSTRUCTION: XOR C ; opcode A9 cycles 04 +INSTRUCTION: XOR D ; opcode AA cycles 04 +INSTRUCTION: XOR E ; opcode AB cycles 04 +INSTRUCTION: XOR H ; opcode AC cycles 04 +INSTRUCTION: XOR L ; opcode AD cycles 04 +INSTRUCTION: XOR (HL) ; opcode AE cycles 07 +INSTRUCTION: XOR A ; opcode AF cycles 04 +INSTRUCTION: OR B ; opcode B0 cycles 04 +INSTRUCTION: OR C ; opcode B1 cycles 04 +INSTRUCTION: OR D ; opcode B2 cycles 04 +INSTRUCTION: OR E ; opcode B3 cycles 04 +INSTRUCTION: OR H ; opcode B4 cycles 04 +INSTRUCTION: OR L ; opcode B5 cycles 04 +INSTRUCTION: OR (HL) ; opcode B6 cycles 07 +INSTRUCTION: OR A ; opcode B7 cycles 04 +INSTRUCTION: CP B ; opcode B8 cycles 04 +INSTRUCTION: CP C ; opcode B9 cycles 04 +INSTRUCTION: CP D ; opcode BA cycles 04 +INSTRUCTION: CP E ; opcode BB cycles 04 +INSTRUCTION: CP H ; opcode BC cycles 04 +INSTRUCTION: CP L ; opcode BD cycles 04 +INSTRUCTION: CP (HL) ; opcode BE cycles 07 +INSTRUCTION: CP A ; opcode BF cycles 04 +INSTRUCTION: RET NZ ; opcode C0 cycles 05 +INSTRUCTION: POP BC ; opcode C1 cycles 10 +INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10 +INSTRUCTION: JP nn ; opcode C3 cycles 10 +INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11 +INSTRUCTION: PUSH BC ; opcode C5 cycles 11 +INSTRUCTION: ADD A,n ; opcode C6 cycles 07 +INSTRUCTION: RST 0 ; opcode C7 cycles 11 +INSTRUCTION: RET Z ; opcode C8 cycles 05 +INSTRUCTION: RET nn ; opcode C9 cycles 10 +INSTRUCTION: JP Z,nn ; opcode CA cycles 10 +INSTRUCTION: CALL Z,nn ; opcode CC cycles 11 +INSTRUCTION: CALL nn ; opcode CD cycles 17 +INSTRUCTION: ADC A,n ; opcode CE cycles 07 +INSTRUCTION: RST 8 ; opcode CF cycles 11 +INSTRUCTION: RET NC ; opcode D0 cycles 05 +INSTRUCTION: POP DE ; opcode D1 cycles 10 +INSTRUCTION: JP NC,nn ; opcode D2 cycles 10 +INSTRUCTION: OUT (n),A ; opcode D3 cycles 10 +INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11 +INSTRUCTION: PUSH DE ; opcode D5 cycles 11 +INSTRUCTION: SUB n ; opcode D6 cycles 07 +INSTRUCTION: RST 10H ; opcode D7 cycles 11 +INSTRUCTION: RET C ; opcode D8 cycles 05 +INSTRUCTION: JP C,nn ; opcode DA cycles 10 +INSTRUCTION: IN A,(n) ; opcode DB cycles 10 +INSTRUCTION: CALL C,nn ; opcode DC cycles 11 +INSTRUCTION: SBC A,n ; opcode DE cycles 07 +INSTRUCTION: RST 18H ; opcode DF cycles 11 +INSTRUCTION: RET PO ; opcode E0 cycles 05 +INSTRUCTION: POP HL ; opcode E1 cycles 10 +INSTRUCTION: JP PO,nn ; opcode E2 cycles 10 +INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04 +INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11 +INSTRUCTION: PUSH HL ; opcode E5 cycles 11 +INSTRUCTION: AND n ; opcode E6 cycles 07 +INSTRUCTION: RST 20H ; opcode E7 cycles 11 +INSTRUCTION: RET PE ; opcode E8 cycles 05 +INSTRUCTION: JP (HL) ; opcode E9 cycles 04 +INSTRUCTION: JP PE,nn ; opcode EA cycles 10 +INSTRUCTION: EX DE,HL ; opcode EB cycles 04 +INSTRUCTION: CALL PE,nn ; opcode EC cycles 11 +INSTRUCTION: XOR n ; opcode EE cycles 07 +INSTRUCTION: RST 28H ; opcode EF cycles 11 +INSTRUCTION: RET P ; opcode F0 cycles 05 +INSTRUCTION: POP AF ; opcode F1 cycles 10 +INSTRUCTION: JP P,nn ; opcode F2 cycles 10 +INSTRUCTION: DI ; opcode F3 cycles 04 +INSTRUCTION: CALL P,nn ; opcode F4 cycles 11 +INSTRUCTION: PUSH AF ; opcode F5 cycles 11 +INSTRUCTION: OR n ; opcode F6 cycles 07 +INSTRUCTION: RST 30H ; opcode F7 cycles 11 +INSTRUCTION: RET M ; opcode F8 cycles 05 +INSTRUCTION: LD SP,HL ; opcode F9 cycles 06 +INSTRUCTION: JP M,nn ; opcode FA cycles 10 +INSTRUCTION: EI ; opcode FB cycles 04 +INSTRUCTION: CALL M,nn ; opcode FC cycles 11 +INSTRUCTION: CP n ; opcode FE cycles 07 +INSTRUCTION: RST 38H ; opcode FF cycles 11 diff --git a/unmaintained/space-invaders/authors.txt b/extra/cpu/8080/authors.txt similarity index 100% rename from unmaintained/space-invaders/authors.txt rename to extra/cpu/8080/authors.txt diff --git a/extra/cpu/8080/emulator/authors.txt b/extra/cpu/8080/emulator/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/cpu/8080/emulator/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/cpu/8080/emulator/emulator-docs.factor b/extra/cpu/8080/emulator/emulator-docs.factor new file mode 100644 index 0000000000..438b5cf268 --- /dev/null +++ b/extra/cpu/8080/emulator/emulator-docs.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax sequences strings ; +IN: cpu.8080.emulator + +HELP: load-rom +{ $values { "filename" string } { "cpu" cpu } } +{ $description +"Read the ROM file into the cpu's memory starting at address 0000. " +"The filename is relative to the path stored in the " { $link rom-root } +" variable. An exception is thrown if this variable is not set." +} +{ $see-also load-rom* } ; + +HELP: load-rom* +{ $values { "seq" sequence } { "cpu" cpu } } +{ $description +"Loads one or more ROM files into the cpu's memory. Each file is " +"loaded at a particular starting address. 'seq' is a sequence of " +"2 element arrays. The first element is the address and the second " +"element is the file to load at that address." $nl +"The filenames are relative to the path stored in the " { $link rom-root } +" variable. An exception is thrown if this variable is not set." +} +{ $examples + { $code "{ { HEX: 0000 \"invaders.rom\" } } load-rom*" } +} +{ $see-also load-rom } ; + +HELP: rom-root +{ $description +"Holds the path where the ROM files are stored. Used for expanding " +"the relative filenames passed to " { $link load-rom } " and " +{ $link load-rom* } "." +} +{ $see-also load-rom load-rom* } ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor new file mode 100755 index 0000000000..04c47caf4a --- /dev/null +++ b/extra/cpu/8080/emulator/emulator.factor @@ -0,0 +1,1407 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: + accessors + arrays + 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 + +TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; + +GENERIC: reset ( cpu -- ) +GENERIC: update-video ( value addr cpu -- ) +GENERIC: read-port ( port cpu -- byte ) +GENERIC: write-port ( value port cpu -- ) + +M: cpu update-video ( value addr cpu -- ) + 3drop ; + +M: cpu read-port ( port cpu -- byte ) + #! Read a byte from the hardware port. 'port' should + #! be an 8-bit value. + 2drop 0 ; + +M: cpu write-port ( value port cpu -- ) + #! Write a byte to the hardware port, where 'port' is + #! an 8-bit value. + 3drop ; + +CONSTANT: carry-flag HEX: 01 +CONSTANT: parity-flag HEX: 04 +CONSTANT: half-carry-flag HEX: 10 +CONSTANT: interrupt-flag HEX: 20 +CONSTANT: zero-flag HEX: 40 +CONSTANT: sign-flag HEX: 80 + +: >word< ( word -- byte byte ) + #! Explode a word into its two 8 bit values. + dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ; + +: af>> ( cpu -- word ) + #! Return the 16-bit pseudo register AF. + [ a>> 8 shift ] keep f>> bitor ; + +: (>>af) ( value cpu -- ) + #! Set the value of the 16-bit pseudo register AF + [ >word< ] dip swap >>f swap >>a drop ; + +: bc>> ( cpu -- word ) + #! Return the 16-bit pseudo register BC. + [ b>> 8 shift ] keep c>> bitor ; + +: (>>bc) ( value cpu -- ) + #! Set the value of the 16-bit pseudo register BC + [ >word< ] dip swap >>c swap >>b drop ; + +: de>> ( cpu -- word ) + #! Return the 16-bit pseudo register DE. + [ d>> 8 shift ] keep e>> bitor ; + +: (>>de) ( value cpu -- ) + #! Set the value of the 16-bit pseudo register DE + [ >word< ] dip swap >>e swap >>d drop ; + +: hl>> ( cpu -- word ) + #! Return the 16-bit pseudo register HL. + [ h>> 8 shift ] keep l>> bitor ; + +: (>>hl) ( value cpu -- ) + #! Set the value of the 16-bit pseudo register HL + [ >word< ] dip swap >>l swap >>h drop ; + +: flag-set? ( flag cpu -- bool ) + f>> bitand 0 = not ; + +: flag-clear? ( flag cpu -- bool ) + f>> bitand 0 = ; + +: flag-nz? ( cpu -- bool ) + #! Test flag status + f>> zero-flag bitand 0 = ; + +: flag-z? ( cpu -- bool ) + #! Test flag status + f>> zero-flag bitand 0 = not ; + +: flag-nc? ( cpu -- bool ) + #! Test flag status + f>> carry-flag bitand 0 = ; + +: flag-c? ( cpu -- bool ) + #! Test flag status + f>> carry-flag bitand 0 = not ; + +: flag-po? ( cpu -- bool ) + #! Test flag status + f>> parity-flag bitand 0 = ; + +: flag-pe? ( cpu -- bool ) + #! Test flag status + f>> parity-flag bitand 0 = not ; + +: flag-p? ( cpu -- bool ) + #! Test flag status + f>> sign-flag bitand 0 = ; + +: flag-m? ( cpu -- bool ) + #! Test flag status + f>> sign-flag bitand 0 = not ; + +: read-byte ( addr cpu -- byte ) + #! Read one byte from memory at the specified address. + #! The address is 16-bit, but if a value greater than + #! 0xFFFF is provided then return a default value. + over HEX: FFFF <= [ + ram>> nth + ] [ + 2drop HEX: FF + ] if ; + +: read-word ( addr cpu -- word ) + #! Read a 16-bit word from memory at the specified address. + #! The address is 16-bit, but if a value greater than + #! 0xFFFF is provided then return a default value. + [ read-byte ] 2keep [ 1 + ] dip read-byte 8 shift bitor ; + +: next-byte ( cpu -- byte ) + #! Return the value of the byte at PC, and increment PC. + [ pc>> ] keep + [ read-byte ] keep + [ pc>> 1 + ] keep + (>>pc) ; + +: next-word ( cpu -- word ) + #! Return the value of the word at PC, and increment PC. + [ pc>> ] keep + [ read-word ] keep + [ pc>> 2 + ] keep + (>>pc) ; + + +: write-byte ( value addr cpu -- ) + #! Write a byte to the specified memory address. + over dup HEX: 2000 < swap HEX: FFFF > or [ + 3drop + ] [ + 3dup ram>> set-nth + update-video + ] if ; + + +: write-word ( value addr cpu -- ) + #! Write a 16-bit word to the specified memory address. + [ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ; + +: cpu-a-bitand ( quot cpu -- ) + #! A &= quot call + [ a>> swap call bitand ] keep (>>a) ; inline + +: cpu-a-bitor ( quot cpu -- ) + #! A |= quot call + [ a>> swap call bitor ] keep (>>a) ; inline + +: cpu-a-bitxor ( quot cpu -- ) + #! A ^= quot call + [ a>> swap call bitxor ] keep (>>a) ; inline + +: cpu-a-bitxor= ( value cpu -- ) + #! cpu-a ^= value + [ a>> bitxor ] keep (>>a) ; + +: cpu-f-bitand ( quot cpu -- ) + #! F &= quot call + [ f>> swap call bitand ] keep (>>f) ; inline + +: cpu-f-bitor ( quot cpu -- ) + #! F |= quot call + [ f>> swap call bitor ] keep (>>f) ; inline + +: cpu-f-bitxor ( quot cpu -- ) + #! F |= quot call + [ f>> swap call bitxor ] keep (>>f) ; inline + +: cpu-f-bitor= ( value cpu -- ) + #! cpu-f |= value + [ f>> bitor ] keep (>>f) ; + +: cpu-f-bitand= ( value cpu -- ) + #! cpu-f &= value + [ f>> bitand ] keep (>>f) ; + +: cpu-f-bitxor= ( value cpu -- ) + #! cpu-f ^= value + [ f>> bitxor ] keep (>>f) ; + +: set-flag ( cpu flag -- ) + swap cpu-f-bitor= ; + +: clear-flag ( cpu flag -- ) + bitnot HEX: FF bitand swap cpu-f-bitand= ; + +: update-zero-flag ( result cpu -- ) + #! If the result of an instruction has the value 0, this + #! flag is set, otherwise it is reset. + swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ; + +: update-sign-flag ( result cpu -- ) + #! If the most significant bit of the result + #! has the value 1 then the flag is set, otherwise + #! it is reset. + swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ; + +: update-parity-flag ( result cpu -- ) + #! If the modulo 2 sum of the bits of the result + #! is 0, (ie. if the result has even parity) this flag + #! is set, otherwise it is reset. + swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ; + +: update-carry-flag ( result cpu -- ) + #! If the instruction resulted in a carry (from addition) + #! or a borrow (from subtraction or a comparison) out of the + #! higher order bit, this flag is set, otherwise it is reset. + swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ; + +: update-half-carry-flag ( original change-by result cpu -- ) + #! If the instruction caused a carry out of bit 3 and into bit 4 of the + #! resulting value, the half carry flag is set, otherwise it is reset. + #! The 'original' is the original value of the register being changed. + #! 'change-by' is the amount it is being added or decremented by. + #! 'result' is the result of that change. + [ bitxor bitxor HEX: 10 bitand 0 = not ] dip + swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ; + +: update-flags ( result cpu -- ) + 2dup update-carry-flag + 2dup update-parity-flag + 2dup update-sign-flag + update-zero-flag ; + +: update-flags-no-carry ( result cpu -- ) + 2dup update-parity-flag + 2dup update-sign-flag + update-zero-flag ; + +: add-byte ( lhs rhs cpu -- result ) + #! Add rhs to lhs + [ 2dup + ] dip + [ update-flags ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: add-carry ( change-by result cpu -- change-by result ) + #! Add the effect of the carry flag to the result + flag-c? [ 1 + [ 1 + ] dip ] when ; + +: add-byte-with-carry ( lhs rhs cpu -- result ) + #! Add rhs to lhs plus carry. + [ 2dup + ] dip + [ add-carry ] keep + [ update-flags ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: sub-carry ( change-by result cpu -- change-by result ) + #! Subtract the effect of the carry flag from the result + flag-c? [ 1 - [ 1 - ] dip ] when ; + +: sub-byte ( lhs rhs cpu -- result ) + #! Subtract rhs from lhs + [ 2dup - ] dip + [ update-flags ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: sub-byte-with-carry ( lhs rhs cpu -- result ) + #! Subtract rhs from lhs and take carry into account + [ 2dup - ] dip + [ sub-carry ] keep + [ update-flags ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: inc-byte ( byte cpu -- result ) + #! Increment byte by one. Note that carry flag is not affected + #! by this operation. + [ 1 2dup + ] dip + [ update-flags-no-carry ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: dec-byte ( byte cpu -- result ) + #! Decrement byte by one. Note that carry flag is not affected + #! by this operation. + [ 1 2dup - ] dip + [ update-flags-no-carry ] 2keep + [ update-half-carry-flag ] 2keep + drop HEX: FF bitand ; + +: inc-word ( w cpu -- w ) + #! Increment word by one. Note that no flags are modified. + drop 1 + HEX: FFFF bitand ; + +: dec-word ( w cpu -- w ) + #! Decrement word by one. Note that no flags are modified. + drop 1 - HEX: FFFF bitand ; + +: add-word ( lhs rhs cpu -- result ) + #! 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. + [ + ] dip over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ; + +: bit3or ( lhs rhs -- 0|1 ) + #! bitor bit 3 of the two numbers on the stack + BIN: 00001000 bitand -3 shift [ + BIN: 00001000 bitand -3 shift + ] dip + bitor ; + +: and-byte ( lhs rhs cpu -- result ) + #! 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. + [ drop bit3or ] 3keep ! bit3or lhs rhs cpu + [ bitand ] dip [ update-flags ] 2keep + [ carry-flag clear-flag ] keep + rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if + HEX: FF bitand ; + +: xor-byte ( lhs rhs cpu -- result ) + #! Logically xor rhs to lhs. The carry and half-carry flags are cleared. + [ bitxor ] dip [ update-flags ] 2keep + [ half-carry-flag carry-flag bitor clear-flag ] keep + drop HEX: FF bitand ; + +: or-byte ( lhs rhs cpu -- result ) + #! Logically or rhs to lhs. The carry and half-carry flags are cleared. + [ bitor ] dip [ update-flags ] 2keep + [ half-carry-flag carry-flag bitor clear-flag ] keep + drop HEX: FF bitand ; + +: decrement-sp ( n cpu -- ) + #! Decrement the stackpointer by n. + [ sp>> ] keep + [ swap - ] dip (>>sp) ; + +: save-pc ( cpu -- ) + #! Save the value of the PC on the stack. + [ pc>> ] keep ! pc cpu + [ sp>> ] keep ! pc sp cpu + write-word ; + +: push-pc ( cpu -- ) + #! Push the value of the PC on the stack. + 2 over decrement-sp + save-pc ; + +: pop-pc ( cpu -- pc ) + #! Pop the value of the PC off the stack. + [ sp>> ] keep + [ read-word ] keep + -2 swap decrement-sp ; + +: push-sp ( value cpu -- ) + [ 2 swap decrement-sp ] keep + [ sp>> ] keep + write-word ; + +: pop-sp ( cpu -- value ) + [ sp>> ] keep + [ read-word ] keep + -2 swap decrement-sp ; + +: call-sub ( addr cpu -- ) + #! Call the address as a subroutine. + dup push-pc + [ HEX: FFFF bitand ] dip (>>pc) ; + +: ret-from-sub ( cpu -- ) + [ pop-pc ] keep (>>pc) ; + +: interrupt ( number cpu -- ) + #! Perform a hardware interrupt +! "***Interrupt: " write over 16 >base print + dup f>> interrupt-flag bitand 0 = not [ + dup push-pc + (>>pc) + ] [ + 2drop + ] if ; + +: inc-cycles ( n cpu -- ) + #! Increment the number of cpu cycles + [ cycles>> + ] keep (>>cycles) ; + +: instruction-cycles ( -- vector ) + #! Return a 256 element vector containing the cycles for + #! each opcode in the 8080 instruction set. + \ instruction-cycles get-global [ + 256 f \ instruction-cycles set-global + ] unless + \ instruction-cycles get-global ; + +: not-implemented ( -- ) + drop ; + +: instructions ( -- vector ) + #! Return a 256 element vector containing the emulation words for + #! each opcode in the 8080 instruction set. + \ instructions get-global [ + 256 [ not-implemented ] \ instructions set-global + ] unless + \ instructions get-global ; + +: set-instruction ( quot n -- ) + instructions set-nth ; + +M: cpu reset ( cpu -- ) + #! Reset the CPU to its poweron state + 0 >>b + 0 >>c + 0 >>d + 0 >>e + 0 >>h + 0 >>l + 0 >>a + 0 >>f + 0 >>pc + HEX: F000 >>sp + HEX: FFFF 0 >>ram + f >>halted? + HEX: 10 >>last-interrupt + 0 >>cycles + drop ; + +: ( -- cpu ) cpu new dup reset ; + +: (load-rom) ( n ram -- ) + read1 [ ! n ram ch + -rot [ set-nth ] 2keep [ 1 + ] dip (load-rom) + ] [ + 2drop + ] if* ; + + #! Reads the ROM from stdin and stores it in ROM from + #! offset n. +: load-rom ( filename cpu -- ) + #! Load the contents of the file into ROM. + #! (address 0x0000-0x1FFF). + ram>> swap binary [ + 0 swap (load-rom) + ] with-file-reader ; + +SYMBOL: rom-root + +: rom-dir ( -- string ) + rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ; + +: load-rom* ( seq cpu -- ) + #! 'seq' is an array of arrays. Each array contains + #! an address and filename of a ROM file. The ROM + #! file will be loaded at the specified address. This + #! file path shoul dbe relative to the '/roms' resource path. + rom-dir [ + ram>> [ + swap first2 rom-dir prepend-path binary [ + swap (load-rom) + ] with-file-reader + ] curry each + ] [ + ! + ! the ROM files. + "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw + ] if ; + +: read-instruction ( cpu -- word ) + #! Read the next instruction from the cpu's program + #! counter, and increment the program counter. + [ pc>> ] keep ! pc cpu + [ over 1 + swap (>>pc) ] keep + read-byte ; + +: get-cycles ( n -- opcode ) + #! Returns the cycles for the given instruction value. + #! If the opcode is not defined throw an error. + dup instruction-cycles nth [ + nip + ] [ + [ "Undefined 8080 opcode: " % number>string % ] "" make throw + ] if* ; + +: process-interrupts ( cpu -- ) + #! Process any hardware interrupts + [ cycles>> ] keep + over 16667 < [ + 2drop + ] [ + [ [ 16667 - ] dip (>>cycles) ] keep + dup last-interrupt>> HEX: 10 = [ + HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt + ] [ + HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt + ] if + ] if ; + +: peek-instruction ( cpu -- word ) + #! Return the next instruction from the cpu's program + #! counter, but don't increment the counter. + [ pc>> ] keep read-byte instructions nth first ; + +: cpu. ( cpu -- ) + [ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep + [ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep + [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep + [ " " write peek-instruction name>> write " " write ] keep + nl drop ; + +: cpu*. ( cpu -- ) + [ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep + [ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep + [ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep + [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep + nl drop ; + +: register-lookup ( string -- vector ) + #! Given a string containing a register name, return a vector + #! where the 1st item is the getter and the 2nd is the setter + #! for that register. + H{ + { "A" { a>> (>>a) } } + { "B" { b>> (>>b) } } + { "C" { c>> (>>c) } } + { "D" { d>> (>>d) } } + { "E" { e>> (>>e) } } + { "H" { h>> (>>h) } } + { "L" { l>> (>>l) } } + { "AF" { af>> (>>af) } } + { "BC" { bc>> (>>bc) } } + { "DE" { de>> (>>de) } } + { "HL" { hl>> (>>hl) } } + { "SP" { sp>> (>>sp) } } + } at ; + + +: flag-lookup ( string -- vector ) + #! Given a string containing a flag name, return a vector + #! where the 1st item is a word that tests that flag. + H{ + { "NZ" { flag-nz? } } + { "NC" { flag-nc? } } + { "PO" { flag-po? } } + { "PE" { flag-pe? } } + { "Z" { flag-z? } } + { "C" { flag-c? } } + { "P" { flag-p? } } + { "M" { flag-m? } } + } at ; + +SYMBOLS: $1 $2 $3 $4 ; + +: replace-patterns ( vector tree -- tree ) + [ + { + { $1 [ first ] } + { $2 [ second ] } + { $3 [ third ] } + { $4 [ fourth ] } + [ nip ] + } case + ] with deep-map ; + +: (emulate-RST) ( n cpu -- ) + #! RST nn + [ sp>> 2 - dup ] keep ! sp sp cpu + [ (>>sp) ] keep ! sp cpu + [ pc>> ] keep ! sp pc cpu + swapd [ write-word ] keep ! cpu + [ 8 * ] dip (>>pc) ; + +: (emulate-CALL) ( cpu -- ) + #! 205 - CALL nn + [ next-word HEX: FFFF bitand ] keep ! addr cpu + [ sp>> 2 - dup ] keep ! addr sp sp cpu + [ (>>sp) ] keep ! addr sp cpu + [ pc>> ] keep ! addr sp pc cpu + swapd [ write-word ] keep ! addr cpu + (>>pc) ; + +: (emulate-RLCA) ( cpu -- ) + #! The content of the accumulator is rotated left + #! one position. The low order bit and the carry flag + #! are both set to the value shifd out of the high + #! order bit position. Only the carry flag is affected. + [ a>> -7 shift ] keep + over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if + [ a>> 1 shift HEX: FF bitand ] keep + [ bitor ] dip (>>a) ; + +: (emulate-RRCA) ( cpu -- ) + #! The content of the accumulator is rotated right + #! one position. The high order bit and the carry flag + #! are both set to the value shifd out of the low + #! order bit position. Only the carry flag is affected. + [ a>> 1 bitand 7 shift ] keep + over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if + [ a>> 254 bitand -1 shift ] keep + [ bitor ] dip (>>a) ; + +: (emulate-RLA) ( cpu -- ) + #! The content of the accumulator is rotated left + #! one position through the carry flag. The low + #! order bit is set equal to the carry flag and + #! the carry flag is set to the value shifd out + #! of the high order bit. Only the carry flag is + #! affected. + [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep + [ a>> 127 bitand 7 shift ] keep + dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if + [ bitor ] dip (>>a) ; + +: (emulate-RRA) ( cpu -- ) + #! The content of the accumulator is rotated right + #! one position through the carry flag. The high order + #! bit is set to the carry flag and the carry flag is + #! set to the value shifd out of the low order bit. + #! Only the carry flag is affected. + [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep + [ a>> 254 bitand -1 shift ] keep + dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if + [ bitor ] dip (>>a) ; + +: (emulate-CPL) ( cpu -- ) + #! The contents of the accumulator are complemented + #! (zero bits become one, one bits becomes zero). + #! No flags are affected. + HEX: FF swap cpu-a-bitxor= ; + +: (emulate-DAA) ( cpu -- ) + #! The eight bit number in the accumulator is + #! adjusted to form two four-bit binary-coded-decimal + #! digits. + [ + dup half-carry-flag swap flag-set? swap + a>> BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if + ] keep + [ a>> + ] keep + [ update-flags ] 2keep + [ swap HEX: FF bitand swap (>>a) ] keep + [ + dup carry-flag swap flag-set? swap + a>> -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if + ] keep + [ a>> + ] keep + [ update-flags ] 2keep + swap HEX: FF bitand swap (>>a) ; + +: patterns ( -- hashtable ) + #! table of code quotation patterns for each type of instruction. + H{ + { "NOP" [ drop ] } + { "RET-NN" [ ret-from-sub ] } + { "RST-0" [ 0 swap (emulate-RST) ] } + { "RST-8" [ 8 swap (emulate-RST) ] } + { "RST-10H" [ HEX: 10 swap (emulate-RST) ] } + { "RST-18H" [ HEX: 18 swap (emulate-RST) ] } + { "RST-20H" [ HEX: 20 swap (emulate-RST) ] } + { "RST-28H" [ HEX: 28 swap (emulate-RST) ] } + { "RST-30H" [ HEX: 30 swap (emulate-RST) ] } + { "RST-38H" [ HEX: 38 swap (emulate-RST) ] } + { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] } + { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] } + { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] } + { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } + { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep (>>a) ] } + { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep (>>a) ] } + { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep (>>a) ] } + { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep (>>a) ] } + { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep (>>a) ] } + { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep (>>a) ] } + { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep (>>a) ] } + { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep (>>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,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 ] } + { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } + { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } + { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } + { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] 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,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep (>>a) ] } + { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep (>>a) ] } + { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep (>>a) ] } + { "CPL" [ (emulate-CPL) ] } + { "DAA" [ (emulate-DAA) ] } + { "RLA" [ (emulate-RLA) ] } + { "RRA" [ (emulate-RRA) ] } + { "CCF" [ carry-flag swap cpu-f-bitxor= ] } + { "SCF" [ carry-flag swap cpu-f-bitor= ] } + { "RLCA" [ (emulate-RLCA) ] } + { "RRCA" [ (emulate-RRCA) ] } + { "HALT" [ drop ] } + { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } + { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } + { "POP-RR" [ [ pop-sp ] keep $2 ] } + { "PUSH-RR" [ [ $1 ] keep push-sp ] } + { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } + { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } + { "INC-RR" [ [ $1 ] keep [ inc-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 ] } + { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] } + { "JP-NN" [ [ pc>> ] keep [ read-word ] keep (>>pc) ] } + { "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 (>>pc) ] } + { "CALL-NN" [ (emulate-CALL) ] } + { "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,RR" [ [ $3 ] keep $2 ] } + { "LD-R,N" [ [ next-byte ] keep $2 ] } + { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } + { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } + { "LD-R,R" [ [ $3 ] keep $2 ] } + { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } + { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } + { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } + { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } + { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } + { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } + { "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 [ $3 ] keep [ $2 ] keep $4 ] } + } ; + +: 8-bit-registers ( -- parser ) + #! A parser for 8-bit registers. On a successfull parse the + #! parse tree contains a vector. The first item in the vector + #! is the getter word for that register with stack effect + #! ( cpu -- value ). The second item is the setter word with + #! stack effect ( value cpu -- ). + [[ register-lookup ]] + EBNF> ; + +: all-flags ( -- parser ) + #! A parser for 16-bit flags. + [[ flag-lookup ]] + EBNF> ; + +: 16-bit-registers ( -- parser ) + #! A parser for 16-bit registers. On a successfull parse the + #! parse tree contains a vector. The first item in the vector + #! is the getter word for that register with stack effect + #! ( cpu -- value ). The second item is the setter word with + #! stack effect ( value cpu -- ). + [[ register-lookup ]] + EBNF> ; + +: all-registers ( -- parser ) + #! Return a parser that can parse the format + #! for 8 bit or 16 bit registers. + [ 16-bit-registers , 8-bit-registers , ] choice* ; + +: indirect ( parser -- parser ) + #! Given a parser, return a parser which parses the original + #! wrapped in brackets, representing an indirect reference. + #! eg. BC -> (BC). The value of the original parser is left in + #! the parse tree. + "(" ")" surrounded-by ; + +: generate-instruction ( vector string -- quot ) + #! Generate the quotation for an instruction, given the instruction in + #! the 'string' and a vector containing the arguments for that instruction. + patterns at replace-patterns ; + +: simple-instruction ( token -- parser ) + #! Return a parser for then instruction identified by the token. + #! The parser return parses the token only and expects no additional + #! arguments to the instruction. + token [ '[ { } _ generate-instruction ] ] action ; + +: complex-instruction ( type token -- parser ) + #! Return a parser for an instruction identified by the token. + #! The instruction is expected to take additional arguments by + #! being combined with other parsers. Then 'type' is used for a lookup + #! in a pattern hashtable to return the instruction quotation pattern. + token swap [ nip '[ _ generate-instruction ] ] curry action ; + +: no-params ( ast -- ast ) + first { } swap curry ; + +: one-param ( ast -- ast ) + first2 swap curry ; + +: two-params ( ast -- ast ) + first3 append swap curry ; + +: NOP-instruction ( -- parser ) + "NOP" simple-instruction ; + +: RET-NN-instruction ( -- parser ) + [ + "RET-NN" "RET" complex-instruction , + "nn" token sp hide , + ] seq* [ no-params ] action ; + +: RST-0-instruction ( -- parser ) + [ + "RST-0" "RST" complex-instruction , + "0" token sp hide , + ] seq* [ no-params ] action ; + +: RST-8-instruction ( -- parser ) + [ + "RST-8" "RST" complex-instruction , + "8" token sp hide , + ] seq* [ no-params ] action ; + +: RST-10H-instruction ( -- parser ) + [ + "RST-10H" "RST" complex-instruction , + "10H" token sp hide , + ] seq* [ no-params ] action ; + +: RST-18H-instruction ( -- parser ) + [ + "RST-18H" "RST" complex-instruction , + "18H" token sp hide , + ] seq* [ no-params ] action ; + +: RST-20H-instruction ( -- parser ) + [ + "RST-20H" "RST" complex-instruction , + "20H" token sp hide , + ] seq* [ no-params ] action ; + +: RST-28H-instruction ( -- parser ) + [ + "RST-28H" "RST" complex-instruction , + "28H" token sp hide , + ] seq* [ no-params ] action ; + +: RST-30H-instruction ( -- parser ) + [ + "RST-30H" "RST" complex-instruction , + "30H" token sp hide , + ] seq* [ no-params ] action ; + +: RST-38H-instruction ( -- parser ) + [ + "RST-38H" "RST" complex-instruction , + "38H" token sp hide , + ] seq* [ no-params ] action ; + +: JP-NN-instruction ( -- parser ) + [ + "JP-NN" "JP" complex-instruction , + "nn" token sp hide , + ] seq* [ no-params ] action ; + +: JP-F|FF,NN-instruction ( -- parser ) + [ + "JP-F|FF,NN" "JP" complex-instruction , + all-flags sp , + ",nn" token hide , + ] seq* [ one-param ] action ; + +: JP-(RR)-instruction ( -- parser ) + [ + "JP-(RR)" "JP" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: CALL-NN-instruction ( -- parser ) + [ + "CALL-NN" "CALL" complex-instruction , + "nn" token sp hide , + ] seq* [ no-params ] action ; + +: CALL-F|FF,NN-instruction ( -- parser ) + [ + "CALL-F|FF,NN" "CALL" complex-instruction , + all-flags sp , + ",nn" token hide , + ] seq* [ one-param ] action ; + +: RLCA-instruction ( -- parser ) + "RLCA" simple-instruction ; + +: RRCA-instruction ( -- parser ) + "RRCA" simple-instruction ; + +: HALT-instruction ( -- parser ) + "HALT" simple-instruction ; + +: DI-instruction ( -- parser ) + "DI" simple-instruction ; + +: EI-instruction ( -- parser ) + "EI" simple-instruction ; + +: CPL-instruction ( -- parser ) + "CPL" simple-instruction ; + +: CCF-instruction ( -- parser ) + "CCF" simple-instruction ; + +: SCF-instruction ( -- parser ) + "SCF" simple-instruction ; + +: DAA-instruction ( -- parser ) + "DAA" simple-instruction ; + +: RLA-instruction ( -- parser ) + "RLA" simple-instruction ; + +: RRA-instruction ( -- parser ) + "RRA" simple-instruction ; + +: DEC-R-instruction ( -- parser ) + [ + "DEC-R" "DEC" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: DEC-RR-instruction ( -- parser ) + [ + "DEC-RR" "DEC" complex-instruction , + 16-bit-registers sp , + ] seq* [ one-param ] action ; + +: DEC-(RR)-instruction ( -- parser ) + [ + "DEC-(RR)" "DEC" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: POP-RR-instruction ( -- parser ) + [ + "POP-RR" "POP" complex-instruction , + all-registers sp , + ] seq* [ one-param ] action ; + +: PUSH-RR-instruction ( -- parser ) + [ + "PUSH-RR" "PUSH" complex-instruction , + all-registers sp , + ] seq* [ one-param ] action ; + +: INC-R-instruction ( -- parser ) + [ + "INC-R" "INC" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: INC-RR-instruction ( -- parser ) + [ + "INC-RR" "INC" complex-instruction , + 16-bit-registers sp , + ] seq* [ one-param ] action ; + +: INC-(RR)-instruction ( -- parser ) + [ + "INC-(RR)" "INC" complex-instruction , + all-registers indirect sp , + ] seq* [ one-param ] action ; + +: RET-F|FF-instruction ( -- parser ) + [ + "RET-F|FF" "RET" complex-instruction , + all-flags sp , + ] seq* [ one-param ] action ; + +: AND-N-instruction ( -- parser ) + [ + "AND-N" "AND" complex-instruction , + "n" token sp hide , + ] seq* [ no-params ] action ; + +: AND-R-instruction ( -- parser ) + [ + "AND-R" "AND" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: AND-(RR)-instruction ( -- parser ) + [ + "AND-(RR)" "AND" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: XOR-N-instruction ( -- parser ) + [ + "XOR-N" "XOR" complex-instruction , + "n" token sp hide , + ] seq* [ no-params ] action ; + +: XOR-R-instruction ( -- parser ) + [ + "XOR-R" "XOR" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: XOR-(RR)-instruction ( -- parser ) + [ + "XOR-(RR)" "XOR" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: OR-N-instruction ( -- parser ) + [ + "OR-N" "OR" complex-instruction , + "n" token sp hide , + ] seq* [ no-params ] action ; + +: OR-R-instruction ( -- parser ) + [ + "OR-R" "OR" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: OR-(RR)-instruction ( -- parser ) + [ + "OR-(RR)" "OR" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: CP-N-instruction ( -- parser ) + [ + "CP-N" "CP" complex-instruction , + "n" token sp hide , + ] seq* [ no-params ] action ; + +: CP-R-instruction ( -- parser ) + [ + "CP-R" "CP" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: CP-(RR)-instruction ( -- parser ) + [ + "CP-(RR)" "CP" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: ADC-R,N-instruction ( -- parser ) + [ + "ADC-R,N" "ADC" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ one-param ] action ; + +: ADC-R,R-instruction ( -- parser ) + [ + "ADC-R,R" "ADC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ two-params ] action ; + +: ADC-R,(RR)-instruction ( -- parser ) + [ + "ADC-R,(RR)" "ADC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ two-params ] action ; + +: SBC-R,N-instruction ( -- parser ) + [ + "SBC-R,N" "SBC" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ one-param ] action ; + +: SBC-R,R-instruction ( -- parser ) + [ + "SBC-R,R" "SBC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ two-params ] action ; + +: SBC-R,(RR)-instruction ( -- parser ) + [ + "SBC-R,(RR)" "SBC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ two-params ] action ; + +: SUB-R-instruction ( -- parser ) + [ + "SUB-R" "SUB" complex-instruction , + 8-bit-registers sp , + ] seq* [ one-param ] action ; + +: SUB-(RR)-instruction ( -- parser ) + [ + "SUB-(RR)" "SUB" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ one-param ] action ; + +: SUB-N-instruction ( -- parser ) + [ + "SUB-N" "SUB" complex-instruction , + "n" token sp hide , + ] seq* [ no-params ] action ; + +: ADD-R,N-instruction ( -- parser ) + [ + "ADD-R,N" "ADD" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ one-param ] action ; + +: ADD-R,R-instruction ( -- parser ) + [ + "ADD-R,R" "ADD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ two-params ] action ; + +: ADD-RR,RR-instruction ( -- parser ) + [ + "ADD-RR,RR" "ADD" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ two-params ] action ; + +: ADD-R,(RR)-instruction ( -- parser ) + [ + "ADD-R,(RR)" "ADD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ two-params ] action ; + +: LD-RR,NN-instruction ( -- parser ) + #! LD BC,nn + [ + "LD-RR,NN" "LD" complex-instruction , + 16-bit-registers sp , + ",nn" token hide , + ] seq* [ one-param ] action ; + +: LD-R,N-instruction ( -- parser ) + #! LD B,n + [ + "LD-R,N" "LD" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ one-param ] action ; + +: LD-(RR),N-instruction ( -- parser ) + [ + "LD-(RR),N" "LD" complex-instruction , + 16-bit-registers indirect sp , + ",n" token hide , + ] seq* [ one-param ] action ; + +: LD-(RR),R-instruction ( -- parser ) + #! LD (BC),A + [ + "LD-(RR),R" "LD" complex-instruction , + 16-bit-registers indirect sp , + "," token hide , + 8-bit-registers , + ] seq* [ two-params ] action ; + +: LD-R,R-instruction ( -- parser ) + [ + "LD-R,R" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ two-params ] action ; + +: LD-RR,RR-instruction ( -- parser ) + [ + "LD-RR,RR" "LD" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ two-params ] action ; + +: LD-R,(RR)-instruction ( -- parser ) + [ + "LD-R,(RR)" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ two-params ] action ; + +: LD-(NN),RR-instruction ( -- parser ) + [ + "LD-(NN),RR" "LD" complex-instruction , + "nn" token indirect sp hide , + "," token hide , + 16-bit-registers , + ] seq* [ one-param ] action ; + +: LD-(NN),R-instruction ( -- parser ) + [ + "LD-(NN),R" "LD" complex-instruction , + "nn" token indirect sp hide , + "," token hide , + 8-bit-registers , + ] seq* [ one-param ] action ; + +: LD-RR,(NN)-instruction ( -- parser ) + [ + "LD-RR,(NN)" "LD" complex-instruction , + 16-bit-registers sp , + "," token hide , + "nn" token indirect hide , + ] seq* [ one-param ] action ; + +: LD-R,(NN)-instruction ( -- parser ) + [ + "LD-R,(NN)" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + "nn" token indirect hide , + ] seq* [ one-param ] action ; + +: OUT-(N),R-instruction ( -- parser ) + [ + "OUT-(N),R" "OUT" complex-instruction , + "n" token indirect sp hide , + "," token hide , + 8-bit-registers , + ] seq* [ one-param ] action ; + +: IN-R,(N)-instruction ( -- parser ) + [ + "IN-R,(N)" "IN" complex-instruction , + 8-bit-registers sp , + "," token hide , + "n" token indirect hide , + ] seq* [ one-param ] action ; + +: EX-(RR),RR-instruction ( -- parser ) + [ + "EX-(RR),RR" "EX" complex-instruction , + 16-bit-registers indirect sp , + "," token hide , + 16-bit-registers , + ] seq* [ two-params ] action ; + +: EX-RR,RR-instruction ( -- parser ) + [ + "EX-RR,RR" "EX" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ two-params ] action ; + +: 8080-generator-parser ( -- parser ) + [ + NOP-instruction , + RST-0-instruction , + RST-8-instruction , + RST-10H-instruction , + RST-18H-instruction , + RST-20H-instruction , + RST-28H-instruction , + RST-30H-instruction , + RST-38H-instruction , + JP-F|FF,NN-instruction , + JP-NN-instruction , + JP-(RR)-instruction , + CALL-F|FF,NN-instruction , + CALL-NN-instruction , + CPL-instruction , + CCF-instruction , + SCF-instruction , + DAA-instruction , + RLA-instruction , + RRA-instruction , + RLCA-instruction , + RRCA-instruction , + HALT-instruction , + DI-instruction , + EI-instruction , + AND-N-instruction , + AND-R-instruction , + AND-(RR)-instruction , + XOR-N-instruction , + XOR-R-instruction , + XOR-(RR)-instruction , + OR-N-instruction , + OR-R-instruction , + OR-(RR)-instruction , + CP-N-instruction , + CP-R-instruction , + CP-(RR)-instruction , + DEC-RR-instruction , + DEC-R-instruction , + DEC-(RR)-instruction , + POP-RR-instruction , + PUSH-RR-instruction , + INC-RR-instruction , + INC-R-instruction , + INC-(RR)-instruction , + LD-RR,NN-instruction , + LD-RR,RR-instruction , + LD-R,N-instruction , + LD-R,R-instruction , + LD-(RR),N-instruction , + LD-(RR),R-instruction , + LD-R,(RR)-instruction , + LD-(NN),RR-instruction , + LD-(NN),R-instruction , + LD-RR,(NN)-instruction , + LD-R,(NN)-instruction , + ADC-R,(RR)-instruction , + ADC-R,N-instruction , + ADC-R,R-instruction , + ADD-R,N-instruction , + ADD-R,(RR)-instruction , + ADD-R,R-instruction , + ADD-RR,RR-instruction , + SBC-R,N-instruction , + SBC-R,R-instruction , + SBC-R,(RR)-instruction , + SUB-R-instruction , + SUB-(RR)-instruction , + SUB-N-instruction , + RET-F|FF-instruction , + RET-NN-instruction , + OUT-(N),R-instruction , + IN-R,(N)-instruction , + EX-(RR),RR-instruction , + EX-RR,RR-instruction , + ] choice* [ call( -- quot ) ] action ; + +: instruction-quotations ( string -- emulate-quot ) + #! Given an instruction string, return the emulation quotation for + #! it. This will later be expanded to produce the disassembly and + #! assembly quotations. + 8080-generator-parser parse ; + +SYMBOL: last-instruction +SYMBOL: last-opcode + +: parse-instructions ( list -- ) + #! Process the list of strings, which should make + #! up an 8080 instruction, and output a quotation + #! that would implement that instruction. + dup " " join instruction-quotations + [ + "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at + ] dip (( cpu -- )) define-declared ; + +SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ; + +SYNTAX: cycles + #! Set the number of cycles for the last instruction that was defined. + scan string>number last-opcode global at instruction-cycles set-nth ; + +SYNTAX: opcode ( -- ) + #! Set the opcode number for the last instruction that was defined. + last-instruction global at 1quotation scan 16 base> + dup last-opcode global set-at set-instruction ; + diff --git a/extra/cpu/8080/emulator/summary.txt b/extra/cpu/8080/emulator/summary.txt new file mode 100644 index 0000000000..083492dfc4 --- /dev/null +++ b/extra/cpu/8080/emulator/summary.txt @@ -0,0 +1 @@ +Intel 8080 CPU Emulator diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt new file mode 100644 index 0000000000..ff94650b8e --- /dev/null +++ b/extra/cpu/8080/emulator/tags.txt @@ -0,0 +1 @@ +emulators diff --git a/extra/cpu/8080/summary.txt b/extra/cpu/8080/summary.txt new file mode 100644 index 0000000000..083492dfc4 --- /dev/null +++ b/extra/cpu/8080/summary.txt @@ -0,0 +1 @@ +Intel 8080 CPU Emulator diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt new file mode 100644 index 0000000000..ff94650b8e --- /dev/null +++ b/extra/cpu/8080/tags.txt @@ -0,0 +1 @@ +emulators diff --git a/extra/cpu/8080/test/test.factor b/extra/cpu/8080/test/test.factor new file mode 100755 index 0000000000..6be74156be --- /dev/null +++ b/extra/cpu/8080/test/test.factor @@ -0,0 +1,70 @@ +USING: + accessors + combinators + cpu.8080 + cpu.8080.emulator + io + io.files + io.encodings.ascii + kernel + math + math.bits + sequences + tools.time +; +IN: cpu.8080.test + +: step ( cpu -- ) + #! Run a single 8080 instruction + [ read-instruction ] keep ! n cpu + over get-cycles over inc-cycles + [ swap instructions nth call( cpu -- ) ] keep + [ pc>> HEX: FFFF bitand ] keep + [ (>>pc) ] keep + process-interrupts ; + +: test-step ( cpu -- 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 ) + invaders over load-rom* dup cpu. ; + +: test-n ( n -- ) + test-cpu swap [ test-step ] times drop ; + +: run-n ( cpu n -- cpu ) + [ dup step ] times ; + +: each-8bit ( n quot -- ) + [ 8 ] dip each ; inline + +: >ppm ( cpu filename -- cpu ) + #! Dump the current screen image to a ppm image file with the given name. + ascii [ + "P3" print + "256 224" print + "1" print + 224 [ + 32 [ + over 32 * over + HEX: 2400 + ! cpu h w addr + [ pick ] dip swap ram>> nth [ + [ + " 0 0 0" write + ] [ + " 1 1 1" write + ] if + ] each-8bit drop + ] each drop nl + ] each + ] with-file-writer ; + +: time-test ( -- ) + test-cpu [ 1000000 run-n drop ] time ; diff --git a/extra/space-invaders/authors.txt b/extra/space-invaders/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/space-invaders/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/unmaintained/space-invaders/resources/BaseHit.wav b/extra/space-invaders/resources/BaseHit.wav similarity index 100% rename from unmaintained/space-invaders/resources/BaseHit.wav rename to extra/space-invaders/resources/BaseHit.wav diff --git a/unmaintained/space-invaders/resources/InvHit.Wav b/extra/space-invaders/resources/InvHit.Wav similarity index 100% rename from unmaintained/space-invaders/resources/InvHit.Wav rename to extra/space-invaders/resources/InvHit.Wav diff --git a/unmaintained/space-invaders/resources/Shot.wav b/extra/space-invaders/resources/Shot.wav similarity index 100% rename from unmaintained/space-invaders/resources/Shot.wav rename to extra/space-invaders/resources/Shot.wav diff --git a/unmaintained/space-invaders/resources/Ufo.wav b/extra/space-invaders/resources/Ufo.wav similarity index 100% rename from unmaintained/space-invaders/resources/Ufo.wav rename to extra/space-invaders/resources/Ufo.wav diff --git a/unmaintained/space-invaders/resources/UfoHit.wav b/extra/space-invaders/resources/UfoHit.wav similarity index 100% rename from unmaintained/space-invaders/resources/UfoHit.wav rename to extra/space-invaders/resources/UfoHit.wav diff --git a/unmaintained/space-invaders/resources/Walk1.wav b/extra/space-invaders/resources/Walk1.wav similarity index 100% rename from unmaintained/space-invaders/resources/Walk1.wav rename to extra/space-invaders/resources/Walk1.wav diff --git a/unmaintained/space-invaders/resources/Walk2.wav b/extra/space-invaders/resources/Walk2.wav similarity index 100% rename from unmaintained/space-invaders/resources/Walk2.wav rename to extra/space-invaders/resources/Walk2.wav diff --git a/unmaintained/space-invaders/resources/Walk3.wav b/extra/space-invaders/resources/Walk3.wav similarity index 100% rename from unmaintained/space-invaders/resources/Walk3.wav rename to extra/space-invaders/resources/Walk3.wav diff --git a/unmaintained/space-invaders/resources/Walk4.wav b/extra/space-invaders/resources/Walk4.wav similarity index 100% rename from unmaintained/space-invaders/resources/Walk4.wav rename to extra/space-invaders/resources/Walk4.wav diff --git a/unmaintained/space-invaders/space-invaders-docs.factor b/extra/space-invaders/space-invaders-docs.factor similarity index 100% rename from unmaintained/space-invaders/space-invaders-docs.factor rename to extra/space-invaders/space-invaders-docs.factor diff --git a/unmaintained/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor similarity index 54% rename from unmaintained/space-invaders/space-invaders.factor rename to extra/space-invaders/space-invaders.factor index d3ca3673f4..a978d703c7 100755 --- a/unmaintained/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -1,19 +1,41 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: cpu.8080 cpu.8080.emulator openal math alien.c-types -sequences kernel shuffle arrays io.files combinators ui.gestures -ui.gadgets ui.render opengl.gl system match -ui byte-arrays combinators.lib qualified ; +USING: + accessors + alien.c-types + alien.data + arrays + byte-arrays + calendar + combinators + cpu.8080 + cpu.8080.emulator + io.files + kernel + math + openal + opengl.gl + sequences + ui + ui.gadgets + ui.gestures + ui.render +; QUALIFIED: threads +QUALIFIED: system IN: space-invaders -TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; -: game-width 224 ; inline -: game-height 256 ; inline +<< + "uchar" require-c-array +>> + +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 ) - game-height game-width 3 * * ; + game-height game-width 3 * * uchar ; : bitmap-index ( point -- index ) #! Point is a {x y}. @@ -22,37 +44,37 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s : set-bitmap-pixel ( color point array -- ) #! 'color' is a {r g b}. Point is {x y}. [ bitmap-index ] dip ! color index array - [ [ first ] 2dip set-uchar-nth ] 3keep - [ [ second ] 2dip [ 1 + ] dip set-uchar-nth ] 3keep - [ third ] 2dip [ 2 + ] dip set-uchar-nth ; + [ [ first ] 2dip set-nth ] 3keep + [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep + [ third ] 2dip [ 2 + ] dip set-nth ; : get-bitmap-pixel ( point array -- color ) #! Point is a {x y}. color is a {r g b} [ bitmap-index ] dip - [ uint-nth ] 2keep - [ [ 1 + ] dip uchar-nth ] 2keep - [ 2 + ] dip uchar-nth 3array ; + [ nth ] 2keep + [ [ 1 + ] dip nth ] 2keep + [ 2 + ] dip nth 3array ; -: SOUND-SHOT ( -- number ) 0 ; -: SOUND-UFO ( -- number ) 1 ; -: SOUND-BASE-HIT ( -- number ) 2 ; -: SOUND-INVADER-HIT ( -- number ) 3 ; -: SOUND-WALK1 ( -- number ) 4 ; -: SOUND-WALK2 ( -- number ) 5 ; -: SOUND-WALK3 ( -- number ) 6 ; -: SOUND-WALK4 ( -- number ) 7 ; -: SOUND-UFO-HIT ( -- number ) 8 ; +CONSTANT: SOUND-SHOT 0 +CONSTANT: SOUND-UFO 1 +CONSTANT: SOUND-BASE-HIT 2 +CONSTANT: SOUND-INVADER-HIT 3 +CONSTANT: SOUND-WALK1 4 +CONSTANT: SOUND-WALK2 5 +CONSTANT: SOUND-WALK3 6 +CONSTANT: SOUND-WALK4 7 +CONSTANT: SOUND-UFO-HIT 8 : init-sound ( index cpu filename -- ) - swapd >r space-invaders-sounds nth AL_BUFFER r> + swapd [ sounds>> nth AL_BUFFER ] dip create-buffer-from-wav set-source-param ; : init-sounds ( cpu -- ) 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-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-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep @@ -60,19 +82,19 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s [ 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-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep - f swap set-space-invaders-looping? ; + f swap (>>looping?) ; : ( -- cpu ) - space-invaders construct-delegate - make-opengl-bitmap over set-space-invaders-bitmap + space-invaders new + make-opengl-bitmap over (>>bitmap) [ init-sounds ] keep [ reset ] keep ; : play-invaders-sound ( cpu sound -- ) - swap space-invaders-sounds nth source-play ; + swap sounds>> nth source-play ; : stop-invaders-sound ( cpu sound -- ) - swap space-invaders-sounds nth source-stop ; + swap sounds>> nth source-stop ; : read-port1 ( cpu -- byte ) #! Port 1 maps the keys for space invaders @@ -82,8 +104,8 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s #! Bit 4 = player one fire #! Bit 5 = player one left #! Bit 6 = player one right - [ space-invaders-port1 dup HEX: FE bitand ] keep - set-space-invaders-port1 ; + [ port1>> dup HEX: FE bitand ] keep + (>>port1) ; : read-port2 ( cpu -- byte ) #! Port 2 maps player 2 controls and dip switches @@ -93,14 +115,14 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s #! Bit 5 = player two left #! Bit 6 = player two right #! Bit 7 = show or hide coin info - [ space-invaders-port2i HEX: 8F bitand ] keep - space-invaders-port1 HEX: 70 bitand bitor ; + [ port2i>> HEX: 8F bitand ] keep + port1>> HEX: 70 bitand bitor ; : read-port3 ( cpu -- byte ) #! Used to compute a special formula - [ space-invaders-port4hi 8 shift ] keep - [ space-invaders-port4lo bitor ] keep - space-invaders-port2o shift -8 shift HEX: FF bitand ; + [ port4hi>> 8 shift ] keep + [ port4lo>> bitor ] keep + port2o>> shift -8 shift HEX: FF bitand ; M: space-invaders read-port ( port cpu -- byte ) #! Read a byte from the hardware port. 'port' should @@ -114,16 +136,16 @@ M: space-invaders read-port ( port cpu -- byte ) : write-port2 ( value cpu -- ) #! Setting this value affects the value read from port 3 - set-space-invaders-port2o ; + (>>port2o) ; : 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 ) - >r space-invaders-port3o swap r> bit-newly-set? ; + [ port3o>> swap ] dip bit-newly-set? ; : 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 -- ) #! Connected to the sound hardware @@ -132,25 +154,25 @@ M: space-invaders read-port ( port cpu -- byte ) #! Bit 2 = Your ship hit #! Bit 3 = Invader hit #! 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 - t over set-space-invaders-looping? + t over (>>looping?) ] when - over 0 bit? not over space-invaders-looping? and [ + over 0 bit? not over looping?>> and [ dup SOUND-UFO stop-invaders-sound - f over set-space-invaders-looping? + f over (>>looping?) ] 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 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 - set-space-invaders-port3o ; + (>>port3o) ; : write-port4 ( value cpu -- ) #! Affects the value returned by reading port 3 - [ space-invaders-port4hi ] keep - [ set-space-invaders-port4lo ] keep - set-space-invaders-port4hi ; + [ port4hi>> ] keep + [ (>>port4lo) ] keep + (>>port4hi) ; : write-port5 ( value cpu -- ) #! Plays sounds @@ -165,7 +187,7 @@ M: space-invaders read-port ( port cpu -- byte ) 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 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 -- ) #! Write a byte to the hardware port, where 'port' is @@ -179,33 +201,34 @@ M: space-invaders write-port ( value port cpu -- ) } case ; M: space-invaders reset ( cpu -- ) - [ delegate reset ] keep - [ 0 swap set-space-invaders-port1 ] keep - [ 0 swap set-space-invaders-port2i ] keep - [ 0 swap set-space-invaders-port2o ] keep - [ 0 swap set-space-invaders-port3o ] keep - [ 0 swap set-space-invaders-port4lo ] keep - [ 0 swap set-space-invaders-port4hi ] keep - 0 swap set-space-invaders-port5o ; + dup call-next-method + 0 >>port1 + 0 >>port2i + 0 >>port2o + 0 >>port3o + 0 >>port4lo + 0 >>port4hi + 0 >>port5o + drop ; : gui-step ( cpu -- ) [ read-instruction ] keep ! n cpu over get-cycles over inc-cycles - [ swap instructions case ] keep - [ cpu-pc HEX: FFFF bitand ] keep - set-cpu-pc ; + [ swap instructions nth call( cpu -- ) ] keep + [ pc>> HEX: FFFF bitand ] keep + (>>pc) ; : gui-frame/2 ( cpu -- ) [ gui-step ] keep - [ cpu-cycles ] keep + [ cycles>> ] keep over 16667 < [ ! cycles cpu nip gui-frame/2 ] [ - [ >r 16667 - r> set-cpu-cycles ] keep - dup cpu-last-interrupt HEX: 10 = [ - HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt + [ [ 16667 - ] dip (>>cycles) ] keep + dup last-interrupt>> HEX: 10 = [ + 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 ; @@ -213,77 +236,77 @@ M: space-invaders reset ( cpu -- ) dup gui-frame/2 gui-frame/2 ; : coin-down ( cpu -- ) - [ space-invaders-port1 1 bitor ] keep set-space-invaders-port1 ; + [ port1>> 1 bitor ] keep (>>port1) ; : coin-up ( cpu -- ) - [ space-invaders-port1 255 1 - bitand ] keep set-space-invaders-port1 ; + [ port1>> 255 1 - bitand ] keep (>>port1) ; : player1-down ( cpu -- ) - [ space-invaders-port1 4 bitor ] keep set-space-invaders-port1 ; + [ port1>> 4 bitor ] keep (>>port1) ; : player1-up ( cpu -- ) - [ space-invaders-port1 255 4 - bitand ] keep set-space-invaders-port1 ; + [ port1>> 255 4 - bitand ] keep (>>port1) ; : player2-down ( cpu -- ) - [ space-invaders-port1 2 bitor ] keep set-space-invaders-port1 ; + [ port1>> 2 bitor ] keep (>>port1) ; : player2-up ( cpu -- ) - [ space-invaders-port1 255 2 - bitand ] keep set-space-invaders-port1 ; + [ port1>> 255 2 - bitand ] keep (>>port1) ; : fire-down ( cpu -- ) - [ space-invaders-port1 HEX: 10 bitor ] keep set-space-invaders-port1 ; + [ port1>> HEX: 10 bitor ] keep (>>port1) ; : 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 -- ) - [ space-invaders-port1 HEX: 20 bitor ] keep set-space-invaders-port1 ; + [ port1>> HEX: 20 bitor ] keep (>>port1) ; : 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 -- ) - [ space-invaders-port1 HEX: 40 bitor ] keep set-space-invaders-port1 ; + [ port1>> HEX: 40 bitor ] keep (>>port1) ; : 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? ; invaders-gadget H{ - { T{ key-down f f "ESC" } [ t swap set-invaders-gadget-quit? ] } - { T{ key-down f f "BACKSPACE" } [ invaders-gadget-cpu coin-down ] } - { T{ key-up f f "BACKSPACE" } [ invaders-gadget-cpu coin-up ] } - { T{ key-down f f "1" } [ invaders-gadget-cpu player1-down ] } - { T{ key-up f f "1" } [ invaders-gadget-cpu player1-up ] } - { T{ key-down f f "2" } [ invaders-gadget-cpu player2-down ] } - { T{ key-up f f "2" } [ invaders-gadget-cpu player2-up ] } - { T{ key-down f f "UP" } [ invaders-gadget-cpu fire-down ] } - { T{ key-up f f "UP" } [ invaders-gadget-cpu fire-up ] } - { T{ key-down f f "LEFT" } [ invaders-gadget-cpu left-down ] } - { T{ key-up f f "LEFT" } [ invaders-gadget-cpu left-up ] } - { T{ key-down f f "RIGHT" } [ invaders-gadget-cpu right-down ] } - { T{ key-up f f "RIGHT" } [ invaders-gadget-cpu right-up ] } + { T{ key-down f f "ESC" } [ t swap (>>quit?) ] } + { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] } + { T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] } + { T{ key-down f f "1" } [ cpu>> player1-down ] } + { T{ key-up f f "1" } [ cpu>> player1-up ] } + { T{ key-down f f "2" } [ cpu>> player2-down ] } + { T{ key-up f f "2" } [ cpu>> player2-up ] } + { T{ key-down f f "UP" } [ cpu>> fire-down ] } + { T{ key-up f f "UP" } [ cpu>> fire-up ] } + { T{ key-down f f "LEFT" } [ cpu>> left-down ] } + { T{ key-up f f "LEFT" } [ cpu>> left-up ] } + { T{ key-down f f "RIGHT" } [ cpu>> right-down ] } + { T{ key-up f f "RIGHT" } [ cpu>> right-up ] } } set-gestures : ( cpu -- gadget ) - invaders-gadget construct-gadget - [ set-invaders-gadget-cpu ] keep - f over set-invaders-gadget-quit? ; + invaders-gadget new + swap >>cpu + 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 -- ) 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - >r 224 256 GL_RGB GL_UNSIGNED_BYTE r> - invaders-gadget-cpu space-invaders-bitmap glDrawPixels ; + [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip + cpu>> bitmap>> glDrawPixels ; -: black { 0 0 0 } ; -: white { 255 255 255 } ; -: green { 0 255 0 } ; -: red { 255 0 0 } ; +CONSTANT: black { 0 0 0 } +CONSTANT: white { 255 255 255 } +CONSTANT: green { 0 255 0 } +CONSTANT: red { 255 0 0 } : addr>xy ( addr -- point ) #! Convert video RAM address to base X Y value. point is a {x y}. @@ -297,7 +320,7 @@ M: invaders-gadget draw-gadget* ( gadget -- ) : within ( n a b -- bool ) #! n >= a and n <= b - rot tuck swap <= >r swap >= r> and ; + rot tuck swap <= [ swap >= ] dip and ; : get-point-color ( point -- color ) #! Return the color to use for the given x/y position. @@ -330,47 +353,50 @@ M: invaders-gadget draw-gadget* ( gadget -- ) M: space-invaders update-video ( value addr cpu -- ) over HEX: 2400 >= [ - space-invaders-bitmap -rot do-bitmap-update + bitmap>> -rot do-bitmap-update ] [ 3drop ] if ; : sync-frame ( millis -- millis ) #! Sleep until the time for the next frame arrives. - 1000 60 / >fixnum + millis - dup 0 > - [ threads:sleep ] [ drop threads:yield ] if millis ; + 1000 60 / >fixnum + system:millis - dup 0 > + [ milliseconds threads:sleep ] [ drop threads:yield ] if system:millis ; : invaders-process ( millis gadget -- ) #! Run a space invaders gadget inside a #! concurrent process. Messages can be sent to #! signal key presses, etc. - dup invaders-gadget-quit? [ + dup quit?>> [ 2drop ] [ [ sync-frame ] dip - [ invaders-gadget-cpu gui-frame ] keep + [ cpu>> gui-frame ] keep [ relayout-1 ] keep invaders-process ] if ; M: invaders-gadget graft* ( gadget -- ) - dup invaders-gadget-cpu init-sounds - f over set-invaders-gadget-quit? - [ millis swap invaders-process ] curry + dup cpu>> init-sounds + f over (>>quit?) + [ system:millis swap invaders-process ] curry "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) - t swap set-invaders-gadget-quit? ; + t swap (>>quit?) ; : (run) ( title cpu rom-info -- ) over load-rom* swap open-window ; : run ( -- ) - "Space Invaders" { - { HEX: 0000 "invaders/invaders.h" } - { HEX: 0800 "invaders/invaders.g" } - { HEX: 1000 "invaders/invaders.f" } - { HEX: 1800 "invaders/invaders.e" } - } [ (run) ] with-ui ; + [ + "Space Invaders" { + { HEX: 0000 "invaders/invaders.h" } + { HEX: 0800 "invaders/invaders.g" } + { HEX: 1000 "invaders/invaders.f" } + { HEX: 1800 "invaders/invaders.e" } + } + (run) + ] with-ui ; MAIN: run diff --git a/unmaintained/space-invaders/summary.txt b/extra/space-invaders/summary.txt similarity index 100% rename from unmaintained/space-invaders/summary.txt rename to extra/space-invaders/summary.txt diff --git a/unmaintained/space-invaders/tags.txt b/extra/space-invaders/tags.txt similarity index 100% rename from unmaintained/space-invaders/tags.txt rename to extra/space-invaders/tags.txt From 1223b554ff8bd6ab3ac7e3e6eb18a913d353836c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 16 Oct 2009 11:54:17 +1300 Subject: [PATCH 3/4] Close window when invaders is closed --- extra/space-invaders/space-invaders.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index a978d703c7..0508f9a31c 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -272,10 +272,10 @@ M: space-invaders reset ( cpu -- ) [ port1>> 255 HEX: 40 - bitand ] keep (>>port1) ; -TUPLE: invaders-gadget < gadget cpu quit? ; +TUPLE: invaders-gadget < gadget cpu quit? windowed? ; invaders-gadget H{ - { T{ key-down f f "ESC" } [ t swap (>>quit?) ] } + { T{ key-down f f "ESC" } [ t over (>>quit?) dup windowed?>> [ close-window ] [ drop ] if ] } { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] } { T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] } { T{ key-down f f "1" } [ cpu>> player1-down ] } @@ -386,17 +386,18 @@ M: invaders-gadget ungraft* ( gadget -- ) t swap (>>quit?) ; : (run) ( title cpu rom-info -- ) - over load-rom* swap open-window ; + over load-rom* t >>windowed? swap open-window ; -: run ( -- ) - [ - "Space Invaders" { +CONSTANT: rom-info { { HEX: 0000 "invaders/invaders.h" } { HEX: 0800 "invaders/invaders.g" } { HEX: 1000 "invaders/invaders.f" } - { HEX: 1800 "invaders/invaders.e" } - } - (run) + { HEX: 1800 "invaders/invaders.e" } + } + +: run ( -- ) + [ + "Space Invaders" rom-info (run) ] with-ui ; MAIN: run From 41dd6394271e5589150c168f0957fef4678dd118 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 16 Oct 2009 12:15:10 +1300 Subject: [PATCH 4/4] Fix invaders sound and fix bitrot in balloon-bomber and lunar-rescue --- .../balloon-bomber/authors.txt | 0 .../balloon-bomber/balloon-bomber-docs.factor | 4 ++-- .../balloon-bomber/balloon-bomber.factor | 21 ++++++++++++------- .../balloon-bomber/summary.txt | 0 .../balloon-bomber/tags.txt | 0 .../lunar-rescue/authors.txt | 0 .../lunar-rescue/lunar-rescue-docs.factor | 4 ++-- .../lunar-rescue/lunar-rescue.factor | 21 ++++++++++++------- .../lunar-rescue/summary.txt | 0 {unmaintained => extra}/lunar-rescue/tags.txt | 0 .../space-invaders/space-invaders-docs.factor | 4 ++-- extra/space-invaders/space-invaders.factor | 15 +++++++------ 12 files changed, 43 insertions(+), 26 deletions(-) rename {unmaintained => extra}/balloon-bomber/authors.txt (100%) rename {unmaintained => extra}/balloon-bomber/balloon-bomber-docs.factor (93%) rename {unmaintained => extra}/balloon-bomber/balloon-bomber.factor (56%) rename {unmaintained => extra}/balloon-bomber/summary.txt (100%) rename {unmaintained => extra}/balloon-bomber/tags.txt (100%) rename {unmaintained => extra}/lunar-rescue/authors.txt (100%) rename {unmaintained => extra}/lunar-rescue/lunar-rescue-docs.factor (94%) rename {unmaintained => extra}/lunar-rescue/lunar-rescue.factor (60%) rename {unmaintained => extra}/lunar-rescue/summary.txt (100%) rename {unmaintained => extra}/lunar-rescue/tags.txt (100%) diff --git a/unmaintained/balloon-bomber/authors.txt b/extra/balloon-bomber/authors.txt similarity index 100% rename from unmaintained/balloon-bomber/authors.txt rename to extra/balloon-bomber/authors.txt diff --git a/unmaintained/balloon-bomber/balloon-bomber-docs.factor b/extra/balloon-bomber/balloon-bomber-docs.factor similarity index 93% rename from unmaintained/balloon-bomber/balloon-bomber-docs.factor rename to extra/balloon-bomber/balloon-bomber-docs.factor index 694ac1882a..e80ccb9b2f 100644 --- a/unmaintained/balloon-bomber/balloon-bomber-docs.factor +++ b/extra/balloon-bomber/balloon-bomber-docs.factor @@ -3,7 +3,7 @@ USING: help.syntax help.markup cpu.8080.emulator ; IN: balloon-bomber -HELP: run +HELP: run-balloon { $description "Run the Balloon Bomber emulator in a new window." $nl { $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" } "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:" { $table { "Backspace" "Insert Coin" } diff --git a/unmaintained/balloon-bomber/balloon-bomber.factor b/extra/balloon-bomber/balloon-bomber.factor similarity index 56% rename from unmaintained/balloon-bomber/balloon-bomber.factor rename to extra/balloon-bomber/balloon-bomber.factor index 160447dc79..c52c029c7c 100644 --- a/unmaintained/balloon-bomber/balloon-bomber.factor +++ b/extra/balloon-bomber/balloon-bomber.factor @@ -3,21 +3,28 @@ ! ! 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 -TUPLE: balloon-bomber ; +TUPLE: balloon-bomber < space-invaders ; : ( -- cpu ) - balloon-bomber construct-delegate ; + balloon-bomber new cpu-init ; -: run ( -- ) - "Balloon Bomber" { +CONSTANT: rom-info { { HEX: 0000 "ballbomb/tn01" } { HEX: 0800 "ballbomb/tn02" } { HEX: 1000 "ballbomb/tn03" } { HEX: 1800 "ballbomb/tn04" } { HEX: 4000 "ballbomb/tn05-1" } - } [ (run) ] with-ui ; + } -MAIN: run +: run-balloon ( -- ) + [ "Balloon Bomber" rom-info (run) ] with-ui ; + +MAIN: run-balloon diff --git a/unmaintained/balloon-bomber/summary.txt b/extra/balloon-bomber/summary.txt similarity index 100% rename from unmaintained/balloon-bomber/summary.txt rename to extra/balloon-bomber/summary.txt diff --git a/unmaintained/balloon-bomber/tags.txt b/extra/balloon-bomber/tags.txt similarity index 100% rename from unmaintained/balloon-bomber/tags.txt rename to extra/balloon-bomber/tags.txt diff --git a/unmaintained/lunar-rescue/authors.txt b/extra/lunar-rescue/authors.txt similarity index 100% rename from unmaintained/lunar-rescue/authors.txt rename to extra/lunar-rescue/authors.txt diff --git a/unmaintained/lunar-rescue/lunar-rescue-docs.factor b/extra/lunar-rescue/lunar-rescue-docs.factor similarity index 94% rename from unmaintained/lunar-rescue/lunar-rescue-docs.factor rename to extra/lunar-rescue/lunar-rescue-docs.factor index d54fe7d485..c8cdb3b6ee 100644 --- a/unmaintained/lunar-rescue/lunar-rescue-docs.factor +++ b/extra/lunar-rescue/lunar-rescue-docs.factor @@ -3,7 +3,7 @@ USING: help.syntax help.markup cpu.8080.emulator ; IN: lunar-rescue -HELP: run +HELP: run-lunar { $description "Run the Lunar Rescue emulator in a new window." $nl { $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" } "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:" { $table { "Backspace" "Insert Coin" } diff --git a/unmaintained/lunar-rescue/lunar-rescue.factor b/extra/lunar-rescue/lunar-rescue.factor similarity index 60% rename from unmaintained/lunar-rescue/lunar-rescue.factor rename to extra/lunar-rescue/lunar-rescue.factor index 558b7154d0..1b7ef6bb69 100644 --- a/unmaintained/lunar-rescue/lunar-rescue.factor +++ b/extra/lunar-rescue/lunar-rescue.factor @@ -3,22 +3,29 @@ ! ! 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 -TUPLE: lunar-rescue ; +TUPLE: lunar-rescue < space-invaders ; : ( -- cpu ) - lunar-rescue construct-delegate ; + lunar-rescue new cpu-init ; -: run ( -- ) - "Lunar Rescue" { +CONSTANT: rom-info { { HEX: 0000 "lrescue/lrescue.1" } { HEX: 0800 "lrescue/lrescue.2" } { HEX: 1000 "lrescue/lrescue.3" } { HEX: 1800 "lrescue/lrescue.4" } { HEX: 4000 "lrescue/lrescue.5" } { HEX: 4800 "lrescue/lrescue.6" } - } [ (run) ] with-ui ; + } -MAIN: run +: run-lunar ( -- ) + [ "Lunar Rescue" rom-info (run) ] with-ui ; + +MAIN: run-lunar diff --git a/unmaintained/lunar-rescue/summary.txt b/extra/lunar-rescue/summary.txt similarity index 100% rename from unmaintained/lunar-rescue/summary.txt rename to extra/lunar-rescue/summary.txt diff --git a/unmaintained/lunar-rescue/tags.txt b/extra/lunar-rescue/tags.txt similarity index 100% rename from unmaintained/lunar-rescue/tags.txt rename to extra/lunar-rescue/tags.txt diff --git a/extra/space-invaders/space-invaders-docs.factor b/extra/space-invaders/space-invaders-docs.factor index c4e3a35668..0c02f8fd4c 100644 --- a/extra/space-invaders/space-invaders-docs.factor +++ b/extra/space-invaders/space-invaders-docs.factor @@ -3,7 +3,7 @@ USING: help.syntax help.markup cpu.8080.emulator ; IN: space-invaders -HELP: run +HELP: run-invaders { $description "Run the Space Invaders emulator in a new window." $nl { $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" } "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:" { $table { "Backspace" "Insert Coin" } diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 0508f9a31c..cb0f4319d6 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -12,6 +12,7 @@ USING: cpu.8080 cpu.8080.emulator io.files + io.pathnames kernel math openal @@ -66,7 +67,7 @@ CONSTANT: SOUND-WALK4 7 CONSTANT: SOUND-UFO-HIT 8 : init-sound ( index cpu filename -- ) - swapd [ sounds>> nth AL_BUFFER ] dip + canonicalize-path swapd [ sounds>> nth AL_BUFFER ] dip create-buffer-from-wav set-source-param ; : init-sounds ( cpu -- ) @@ -76,7 +77,7 @@ CONSTANT: SOUND-UFO-HIT 8 [ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] 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-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-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep @@ -84,12 +85,14 @@ CONSTANT: SOUND-UFO-HIT 8 [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep f swap (>>looping?) ; -: ( -- cpu ) - space-invaders new +: cpu-init ( cpu -- cpu ) make-opengl-bitmap over (>>bitmap) [ init-sounds ] keep [ reset ] keep ; +: ( -- cpu ) + space-invaders new cpu-init ; + : play-invaders-sound ( cpu sound -- ) swap sounds>> nth source-play ; @@ -395,9 +398,9 @@ CONSTANT: rom-info { { HEX: 1800 "invaders/invaders.e" } } -: run ( -- ) +: run-invaders ( -- ) [ "Space Invaders" rom-info (run) ] with-ui ; -MAIN: run +MAIN: run-invaders