diff --git a/contrib/parser-combinators/parser-combinators.factor b/contrib/parser-combinators/parser-combinators.factor index 754d2679bd..2ed44f0630 100644 --- a/contrib/parser-combinators/parser-combinators.factor +++ b/contrib/parser-combinators/parser-combinators.factor @@ -20,23 +20,27 @@ ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -USING: lazy-lists kernel sequences strings math io arrays ; +USING: lazy-lists kernel sequences strings math io arrays errors ; IN: parser-combinators TUPLE: parse-result parsed unparsed ; : h:t ( object -- head tail ) #! Return the head and tail of the object. - dup first swap 1 tail ; + dup empty? [ dup first swap 1 tail ] unless ; : token-parser ( inp sequence -- llist ) #! A parser that parses a specific sequence of #! characters. - 2dup length head over = [ - swap over length tail lunit + [ + 2dup length head over = [ + swap over length tail lunit + ] [ + 2drop nil + ] if ] [ - 2drop nil - ] if ; + 3drop nil + ] recover ; : token ( string -- parser ) #! Return a token parser that parses the given string. diff --git a/contrib/space-invaders/cpu-8080.factor b/contrib/space-invaders/cpu-8080.factor index 41614219fb..edc76a3093 100644 --- a/contrib/space-invaders/cpu-8080.factor +++ b/contrib/space-invaders/cpu-8080.factor @@ -20,8 +20,8 @@ ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -USING: kernel lists math sequences errors vectors prettyprint io namespaces arrays - words parser hashtables lazy parser-combinators kernel-internals strings ; +USING: kernel math sequences errors vectors prettyprint io namespaces arrays + words parser hashtables lazy-lists parser-combinators kernel-internals strings ; IN: cpu-8080 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -532,7 +532,7 @@ C: cpu ( cpu -- cpu ) : peek-instruction ( cpu -- word ) #! Return the next instruction from the cpu's program #! counter, but don't increment the counter. - [ cpu-pc ] keep read-byte instructions nth car ; + [ cpu-pc ] keep read-byte instructions nth first ; : cpu. ( cpu -- ) [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep @@ -618,10 +618,10 @@ SYMBOL: $4 #! Copy the tree, replacing each occurence of #! $1, $2, etc with the relevant item from the #! given index. - dup cons? [ ( vector tree ) - uncons ( vector car cdr ) + dup quotation? over [ ] = not and [ ( vector tree ) + dup first swap 1 tail ( vector car cdr ) >r dupd replace-patterns ( vector v R: cdr ) - swap r> replace-patterns cons + swap r> replace-patterns >r unit r> append ] [ ( vector value ) dup $1 = [ drop 0 over nth ] when dup $2 = [ drop 1 over nth ] when @@ -863,7 +863,11 @@ SYMBOL: $4 #! The instruction is expected to take additional arguments by #! 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 , ] [ ] make ] cons <@ ; + token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ; + +: >2array< ( array -- v1 v2 ) + #! Explode a two element array + dup first swap second ; : NOP-instruction ( -- parser ) "NOP" simple-instruction ; @@ -871,74 +875,74 @@ SYMBOL: $4 : RET-NN-instruction ( -- parser ) "RET-NN" "RET" complex-instruction "nn" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-0-instruction ( -- parser ) "RST-0" "RST" complex-instruction "0" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-8-instruction ( -- parser ) "RST-8" "RST" complex-instruction "8" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-10H-instruction ( -- parser ) "RST-10H" "RST" complex-instruction "10H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-18H-instruction ( -- parser ) "RST-18H" "RST" complex-instruction "18H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-20H-instruction ( -- parser ) "RST-20H" "RST" complex-instruction "20H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-28H-instruction ( -- parser ) "RST-28H" "RST" complex-instruction "28H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-30H-instruction ( -- parser ) "RST-30H" "RST" complex-instruction "30H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : RST-38H-instruction ( -- parser ) "RST-38H" "RST" complex-instruction "38H" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : JP-NN-instruction ( -- parser ) "JP-NN" "JP" complex-instruction "nn" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : JP-F|FF,NN-instruction ( -- parser ) "JP-F|FF,NN" "JP" complex-instruction all-flags sp <&> ",nn" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : JP-(RR)-instruction ( -- parser ) "JP-(RR)" "JP" complex-instruction 16-bit-registers indirect sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : CALL-NN-instruction ( -- parser ) "CALL-NN" "CALL" complex-instruction "nn" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : CALL-F|FF,NN-instruction ( -- parser ) "CALL-F|FF,NN" "CALL" complex-instruction all-flags sp <&> ",nn" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; @@ -975,194 +979,194 @@ SYMBOL: $4 : DEC-R-instruction ( -- parser ) "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : DEC-RR-instruction ( -- parser ) "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : DEC-(RR)-instruction ( -- parser ) "DEC-(RR)" "DEC" complex-instruction 16-bit-registers indirect sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : POP-RR-instruction ( -- parser ) "POP-RR" "POP" complex-instruction all-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : PUSH-RR-instruction ( -- parser ) "PUSH-RR" "PUSH" complex-instruction all-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : INC-R-instruction ( -- parser ) "INC-R" "INC" complex-instruction 8-bit-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : INC-RR-instruction ( -- parser ) "INC-RR" "INC" complex-instruction 16-bit-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : INC-(RR)-instruction ( -- parser ) "INC-(RR)" "INC" complex-instruction - all-registers indirect sp <&> just [ uncons swons ] <@ ; + all-registers indirect sp <&> just [ >2array< swap curry ] <@ ; : RET-F|FF-instruction ( -- parser ) "RET-F|FF" "RET" complex-instruction all-flags sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : AND-N-instruction ( -- parser ) "AND-N" "AND" complex-instruction "n" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : AND-R-instruction ( -- parser ) "AND-R" "AND" complex-instruction - 8-bit-registers sp <&> just [ uncons swons ] <@ ; + 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ; : AND-(RR)-instruction ( -- parser ) "AND-(RR)" "AND" complex-instruction - 16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; + 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ; : XOR-N-instruction ( -- parser ) "XOR-N" "XOR" complex-instruction "n" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : XOR-R-instruction ( -- parser ) "XOR-R" "XOR" complex-instruction - 8-bit-registers sp <&> just [ uncons swons ] <@ ; + 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ; : XOR-(RR)-instruction ( -- parser ) "XOR-(RR)" "XOR" complex-instruction - 16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; + 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ; : OR-N-instruction ( -- parser ) "OR-N" "OR" complex-instruction "n" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : OR-R-instruction ( -- parser ) "OR-R" "OR" complex-instruction - 8-bit-registers sp <&> just [ uncons swons ] <@ ; + 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ; : OR-(RR)-instruction ( -- parser ) "OR-(RR)" "OR" complex-instruction - 16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; + 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ; : CP-N-instruction ( -- parser ) "CP-N" "CP" complex-instruction "n" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : CP-R-instruction ( -- parser ) "CP-R" "CP" complex-instruction - 8-bit-registers sp <&> just [ uncons swons ] <@ ; + 8-bit-registers sp <&> just [ >2array< swap curry ] <@ ; : CP-(RR)-instruction ( -- parser ) "CP-(RR)" "CP" complex-instruction - 16-bit-registers indirect sp <&> just [ uncons swons ] <@ ; + 16-bit-registers indirect sp <&> just [ >2array< swap curry ] <@ ; : ADC-R,N-instruction ( -- parser ) "ADC-R,N" "ADC" complex-instruction 8-bit-registers sp <&> ",n" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : ADC-R,R-instruction ( -- parser ) "ADC-R,R" "ADC" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : ADC-R,(RR)-instruction ( -- parser ) "ADC-R,(RR)" "ADC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : SBC-R,N-instruction ( -- parser ) "SBC-R,N" "SBC" complex-instruction 8-bit-registers sp <&> ",n" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : SBC-R,R-instruction ( -- parser ) "SBC-R,R" "SBC" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : SBC-R,(RR)-instruction ( -- parser ) "SBC-R,(RR)" "SBC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : SUB-R-instruction ( -- parser ) "SUB-R" "SUB" complex-instruction 8-bit-registers sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : SUB-(RR)-instruction ( -- parser ) "SUB-(RR)" "SUB" complex-instruction 16-bit-registers indirect sp <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : SUB-N-instruction ( -- parser ) "SUB-N" "SUB" complex-instruction "n" token sp <& - just [ { } clone swons ] <@ ; + just [ { } clone swap curry ] <@ ; : ADD-R,N-instruction ( -- parser ) "ADD-R,N" "ADD" complex-instruction 8-bit-registers sp <&> ",n" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : ADD-R,R-instruction ( -- parser ) "ADD-R,R" "ADD" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : ADD-RR,RR-instruction ( -- parser ) "ADD-RR,RR" "ADD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : ADD-R,(RR)-instruction ( -- parser ) "ADD-R,(RR)" "ADD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : LD-RR,NN-instruction #! LD BC,nn "LD-RR,NN" "LD" complex-instruction 16-bit-registers sp <&> ",nn" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-R,N-instruction #! LD B,n "LD-R,N" "LD" complex-instruction 8-bit-registers sp <&> ",n" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-(RR),N-instruction "LD-(RR),N" "LD" complex-instruction 16-bit-registers indirect sp <&> ",n" token <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-(RR),R-instruction #! LD (BC),A @@ -1170,84 +1174,84 @@ SYMBOL: $4 16-bit-registers indirect sp <&> "," token <& 8-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : LD-R,R-instruction "LD-R,R" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : LD-RR,RR-instruction "LD-RR,RR" "LD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : LD-R,(RR)-instruction "LD-R,(RR)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : LD-(NN),RR-instruction "LD-(NN),RR" "LD" complex-instruction "nn" token indirect sp <& "," token <& 16-bit-registers <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-(NN),R-instruction "LD-(NN),R" "LD" complex-instruction "nn" token indirect sp <& "," token <& 8-bit-registers <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-RR,(NN)-instruction "LD-RR,(NN)" "LD" complex-instruction 16-bit-registers sp <&> "," token <& "nn" token indirect <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : LD-R,(NN)-instruction "LD-R,(NN)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& "nn" token indirect <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : OUT-(N),R-instruction "OUT-(N),R" "OUT" complex-instruction "n" token indirect sp <& "," token <& 8-bit-registers <&> - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : IN-R,(N)-instruction "IN-R,(N)" "IN" complex-instruction 8-bit-registers sp <&> "," token <& "n" token indirect <& - just [ uncons swons ] <@ ; + just [ >2array< swap curry ] <@ ; : EX-(RR),RR-instruction "EX-(RR),RR" "EX" complex-instruction 16-bit-registers indirect sp <&> "," token <& 16-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : EX-RR,RR-instruction "EX-RR,RR" "EX" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ unswons unswons >r swap append r> cons ] <@ ; + just [ >2array< swap >2array< swap >r append r> curry ] <@ ; : 8080-generator-parser NOP-instruction @@ -1355,7 +1359,6 @@ SYMBOL: last-opcode last-instruction global hash unit scan 16 base> ( [word] opcode -- ) dup last-opcode global set-hash instructions set-nth ; parsing - INSTRUCTION: NOP ; opcode 00 cycles 04 INSTRUCTION: LD BC,nn ; opcode 01 cycles 10 INSTRUCTION: LD (BC),A ; opcode 02 cycles 07 diff --git a/contrib/space-invaders/space-invaders.factor b/contrib/space-invaders/space-invaders.factor index 3a7a9d6af0..42a280e6be 100644 --- a/contrib/space-invaders/space-invaders.factor +++ b/contrib/space-invaders/space-invaders.factor @@ -21,7 +21,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. USING: alien cpu-8080 errors generic io kernel kernel-internals -lists math namespaces sequences styles threads gadgets gadgets-layouts opengl arrays +math namespaces sequences styles threads gadgets gadgets opengl arrays concurrency ; IN: space-invaders @@ -161,21 +161,22 @@ TUPLE: right-up-msg ; over send [ 10 sleep swap send ] spawn drop ; : set-key-actions ( gadget -- ) - H{ - { [ "ESCAPE" ] [ invaders-gadget-process "stop" swap send ] } - { [ "BACKSPACE" ] [ invaders-gadget-process coin-key-pressed ] } - { [ "1" ] [ invaders-gadget-process player1-key-pressed ] } - { [ "2" ] [ invaders-gadget-process player2-key-pressed ] } - { [ "UP" ] [ invaders-gadget-process fire-key-pressed ] } - { [ "LEFT" ] [ invaders-gadget-process left-key-pressed ] } - { [ "RIGHT" ] [ invaders-gadget-process right-key-pressed ] } - } add-actions ; +! H{ +! { [ "ESCAPE" ] [ invaders-gadget-process "stop" swap send ] } +! { [ "BACKSPACE" ] [ invaders-gadget-process coin-key-pressed ] } +! { [ "1" ] [ invaders-gadget-process player1-key-pressed ] } +! { [ "2" ] [ invaders-gadget-process player2-key-pressed ] } +! { [ "UP" ] [ invaders-gadget-process fire-key-pressed ] } +! { [ "LEFT" ] [ invaders-gadget-process left-key-pressed ] } +! { [ "RIGHT" ] [ invaders-gadget-process right-key-pressed ] } +! } set-gestures + drop ; C: invaders-gadget ( gadget -- ) dup delegate>gadget dup set-key-actions ; -M: invaders-gadget pref-dim* drop { 224 256 0 0 } ; +M: invaders-gadget pref-dim* drop { 224 256 0 } ; M: invaders-gadget draw-gadget* ( gadget -- ) 0 0 glRasterPos2i @@ -322,6 +323,6 @@ M: right-up-msg handle-invaders-message ( gadget message -- quit? ) : run ( -- process ) "invaders.rom" over load-rom [ set-invaders-gadget-cpu ] keep - dup "Space Invaders" open-window - dup [ millis swap invaders-process ] cons spawn + dup "Space Invaders" open-titled-window + dup [ millis swap invaders-process ] curry spawn swap dupd set-invaders-gadget-process ;