From f90ac9a691dfa2e900a773bb82ee2198a2797b19 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Thu, 10 Jul 2008 16:40:12 -0400 Subject: [PATCH 01/21] Fixed bug in ui.gadgets.tabs --- extra/ui/gadgets/tabs/tabs.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 113ea84443..18542f1089 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -24,13 +24,16 @@ DEFER: (del-page) [ [ length ] keep ] 2dip '[ , _ _ , add-toggle ] 2each ; +: refresh-book ( tabbed -- ) + model>> [ ] change-model ; + : (del-page) ( n name tabbed -- ) { [ [ remove ] change-names redo-toggler ] - [ [ names>> length ] [ model>> ] bi + [ dupd [ names>> length ] [ model>> ] bi [ [ = ] keep swap [ 1- ] when - [ > ] keep swap [ 1- ] when dup ] change-model ] + [ < ] keep swap [ 1- ] when ] change-model ] [ content>> nth-gadget unparent ] - [ model>> [ ] change-model ] ! refresh + [ refresh-book ] } cleave ; : add-page ( page name tabbed -- ) @@ -38,7 +41,8 @@ DEFER: (del-page) [ [ model>> swap ] [ names>> length 1 - swap ] [ toggler>> ] tri add-toggle ] - [ content>> add-gadget ] bi ; + [ content>> add-gadget ] + [ refresh-book ] tri ; : del-page ( name tabbed -- ) [ names>> index ] 2keep (del-page) ; From 2d12fe4f0576bd9075ee9f7932b512c77b72ac57 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 10 Jul 2008 20:11:08 -0300 Subject: [PATCH 02/21] irc.client: Fix tests --- extra/irc/client/client-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index f7065664dd..2883e47b81 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,8 +1,9 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads - calendar irc.client.private concurrency.mailboxes classes ; -EXCLUDE: irc.client => join ; -RENAME: join irc.client => join_ + calendar irc.client.private irc.client irc.messages.private + concurrency.mailboxes classes ; +EXCLUDE: irc.messages => join ; +RENAME: join irc.messages => join_ IN: irc.client.tests ! Utilities From 20b517d7daee13cff78a43236aea1510c9507627 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 21:44:11 +1200 Subject: [PATCH 03/21] Covert cpu.8080 to use pegs --- extra/cpu/8080/emulator/emulator.factor | 723 +++++++++++++----------- 1 file changed, 396 insertions(+), 327 deletions(-) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index ca650a4f01..d29ed23bf0 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: accessors kernel math sequences words arrays io io.files -namespaces math.parser assocs quotations parser lexer -parser-combinators tools.time io.encodings.binary sequences.deep -symbols combinators ; +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 ; @@ -748,24 +748,15 @@ SYMBOLS: $1 $2 $3 $4 ; #! is the getter word for that register with stack effect #! ( cpu -- value ). The second item is the setter word with #! stack effect ( value cpu -- ). - "A" token - "B" token <|> - "C" token <|> - "D" token <|> - "E" token <|> - "H" token <|> - "L" token <|> [ register-lookup ] <@ ; + [[ register-lookup ]] + EBNF> ; : all-flags ( -- parser ) #! A parser for 16-bit flags. - "NZ" token - "NC" token <|> - "PO" token <|> - "PE" token <|> - "Z" token <|> - "C" token <|> - "P" token <|> - "M" token <|> [ flag-lookup ] <@ ; + [[ flag-lookup ]] + EBNF> ; : 16-bit-registers ( -- parser ) #! A parser for 16-bit registers. On a successfull parse the @@ -773,23 +764,21 @@ SYMBOLS: $1 $2 $3 $4 ; #! is the getter word for that register with stack effect #! ( cpu -- value ). The second item is the setter word with #! stack effect ( value cpu -- ). - "AF" token - "BC" token <|> - "DE" token <|> - "HL" token <|> - "SP" token <|> [ register-lookup ] <@ ; + [[ register-lookup ]] + EBNF> ; : all-registers ( -- parser ) #! Return a parser that can parse the format #! for 8 bit or 16 bit registers. - 8-bit-registers 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. - "(" token swap &> ")" token <& ; + "(" ")" surrounded-by ; : generate-instruction ( vector string -- quot ) #! Generate the quotation for an instruction, given the instruction in @@ -800,89 +789,103 @@ SYMBOLS: $1 $2 $3 $4 ; #! 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 [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ; + 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 , ] [ ] make ] curry <@ ; + token swap [ nip '[ , generate-instruction ] ] curry action ; : NOP-instruction ( -- parser ) "NOP" simple-instruction ; : RET-NN-instruction ( -- parser ) - "RET-NN" "RET" complex-instruction - "nn" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RET-NN" "RET" complex-instruction , + "nn" token sp hide , + ] seq* [ first { } swap curry ] action ; : RST-0-instruction ( -- parser ) - "RST-0" "RST" complex-instruction - "0" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RST-0" "RST" complex-instruction , + "0" token sp hide , + ] seq* [ first { } swap curry ] action ; : RST-8-instruction ( -- parser ) - "RST-8" "RST" complex-instruction - "8" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RST-8" "RST" complex-instruction , + "8" token sp hide , + ] seq* [ first { } swap curry ] action ; : RST-10H-instruction ( -- parser ) - "RST-10H" "RST" complex-instruction - "10H" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RST-10H" "RST" complex-instruction , + "10H" token sp hide , + ] seq* [ first { } swap curry ] action ; : RST-18H-instruction ( -- parser ) - "RST-18H" "RST" complex-instruction - "18H" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RST-18H" "RST" complex-instruction , + "18H" token sp hide , + ] seq* [ first { } swap curry ] action ; -: RST-20H-instruction ( -- parser ) - "RST-20H" "RST" complex-instruction - "20H" token sp <& - just [ { } clone swap curry ] <@ ; +: RST-20H-instruction ( -- parser ) + [ + "RST-20H" "RST" complex-instruction , + "20H" token sp hide , + ] seq* [ first { } swap curry ] action ; -: RST-28H-instruction ( -- parser ) - "RST-28H" "RST" complex-instruction - "28H" token sp <& - just [ { } clone swap curry ] <@ ; +: RST-28H-instruction ( -- parser ) + [ + "RST-28H" "RST" complex-instruction , + "28H" token sp hide , + ] seq* [ first { } swap curry ] action ; -: RST-30H-instruction ( -- parser ) - "RST-30H" "RST" complex-instruction - "30H" token sp <& - just [ { } clone swap curry ] <@ ; +: RST-30H-instruction ( -- parser ) + [ + "RST-30H" "RST" complex-instruction , + "30H" token sp hide , + ] seq* [ first { } swap curry ] action ; : RST-38H-instruction ( -- parser ) - "RST-38H" "RST" complex-instruction - "38H" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "RST-38H" "RST" complex-instruction , + "38H" token sp hide , + ] seq* [ first { } swap curry ] action ; : JP-NN-instruction ( -- parser ) - "JP-NN" "JP" complex-instruction - "nn" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "JP-NN" "JP" complex-instruction , + "nn" token sp hide , + ] seq* [ first { } swap curry ] action ; : JP-F|FF,NN-instruction ( -- parser ) - "JP-F|FF,NN" "JP" complex-instruction - all-flags sp <&> - ",nn" token <& - just [ first2 swap curry ] <@ ; + [ + "JP-F|FF,NN" "JP" complex-instruction , + all-flags sp , + ",nn" token hide , + ] seq* [ first2 swap curry ] action ; : JP-(RR)-instruction ( -- parser ) - "JP-(RR)" "JP" complex-instruction - 16-bit-registers indirect sp <&> - just [ first2 swap curry ] <@ ; + [ + "JP-(RR)" "JP" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : CALL-NN-instruction ( -- parser ) - "CALL-NN" "CALL" complex-instruction - "nn" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "CALL-NN" "CALL" complex-instruction , + "nn" token sp hide , + ] seq* [ first { } swap curry ] action ; : CALL-F|FF,NN-instruction ( -- parser ) - "CALL-F|FF,NN" "CALL" complex-instruction - all-flags sp <&> - ",nn" token <& - just [ first2 swap curry ] <@ ; + [ + "CALL-F|FF,NN" "CALL" complex-instruction , + all-flags sp , + ",nn" token hide , + ] seq* [ first2 swap curry ] action ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; @@ -918,364 +921,430 @@ SYMBOLS: $1 $2 $3 $4 ; "RRA" simple-instruction ; : DEC-R-instruction ( -- parser ) - "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "DEC-R" "DEC" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : DEC-RR-instruction ( -- parser ) - "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "DEC-RR" "DEC" complex-instruction , + 16-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : DEC-(RR)-instruction ( -- parser ) - "DEC-(RR)" "DEC" complex-instruction - 16-bit-registers indirect sp <&> - just [ first2 swap curry ] <@ ; + [ + "DEC-(RR)" "DEC" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : POP-RR-instruction ( -- parser ) - "POP-RR" "POP" complex-instruction all-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "POP-RR" "POP" complex-instruction , + all-registers sp , + ] seq* [ first2 swap curry ] action ; : PUSH-RR-instruction ( -- parser ) - "PUSH-RR" "PUSH" complex-instruction all-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "PUSH-RR" "PUSH" complex-instruction , + all-registers sp , + ] seq* [ first2 swap curry ] action ; : INC-R-instruction ( -- parser ) - "INC-R" "INC" complex-instruction 8-bit-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "INC-R" "INC" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : INC-RR-instruction ( -- parser ) - "INC-RR" "INC" complex-instruction 16-bit-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "INC-RR" "INC" complex-instruction , + 16-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : INC-(RR)-instruction ( -- parser ) - "INC-(RR)" "INC" complex-instruction - all-registers indirect sp <&> just [ first2 swap curry ] <@ ; + [ + "INC-(RR)" "INC" complex-instruction , + all-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : RET-F|FF-instruction ( -- parser ) - "RET-F|FF" "RET" complex-instruction all-flags sp <&> - just [ first2 swap curry ] <@ ; + [ + "RET-F|FF" "RET" complex-instruction , + all-flags sp , + ] seq* [ first2 swap curry ] action ; : AND-N-instruction ( -- parser ) - "AND-N" "AND" complex-instruction - "n" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "AND-N" "AND" complex-instruction , + "n" token sp hide , + ] seq* [ first { } swap curry ] action ; : AND-R-instruction ( -- parser ) - "AND-R" "AND" complex-instruction - 8-bit-registers sp <&> just [ first2 swap curry ] <@ ; + [ + "AND-R" "AND" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : AND-(RR)-instruction ( -- parser ) - "AND-(RR)" "AND" complex-instruction - 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; + [ + "AND-(RR)" "AND" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : XOR-N-instruction ( -- parser ) - "XOR-N" "XOR" complex-instruction - "n" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "XOR-N" "XOR" complex-instruction , + "n" token sp hide , + ] seq* [ first { } swap curry ] action ; : XOR-R-instruction ( -- parser ) - "XOR-R" "XOR" complex-instruction - 8-bit-registers sp <&> just [ first2 swap curry ] <@ ; + [ + "XOR-R" "XOR" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : XOR-(RR)-instruction ( -- parser ) - "XOR-(RR)" "XOR" complex-instruction - 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; + [ + "XOR-(RR)" "XOR" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : OR-N-instruction ( -- parser ) - "OR-N" "OR" complex-instruction - "n" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "OR-N" "OR" complex-instruction , + "n" token sp hide , + ] seq* [ first { } swap curry ] action ; : OR-R-instruction ( -- parser ) - "OR-R" "OR" complex-instruction - 8-bit-registers sp <&> just [ first2 swap curry ] <@ ; + [ + "OR-R" "OR" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : OR-(RR)-instruction ( -- parser ) - "OR-(RR)" "OR" complex-instruction - 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; + [ + "OR-(RR)" "OR" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : CP-N-instruction ( -- parser ) - "CP-N" "CP" complex-instruction - "n" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "CP-N" "CP" complex-instruction , + "n" token sp hide , + ] seq* [ first { } swap curry ] action ; : CP-R-instruction ( -- parser ) - "CP-R" "CP" complex-instruction - 8-bit-registers sp <&> just [ first2 swap curry ] <@ ; + [ + "CP-R" "CP" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : CP-(RR)-instruction ( -- parser ) - "CP-(RR)" "CP" complex-instruction - 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; + [ + "CP-(RR)" "CP" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : ADC-R,N-instruction ( -- parser ) - "ADC-R,N" "ADC" complex-instruction - 8-bit-registers sp <&> - ",n" token <& - just [ first2 swap curry ] <@ ; + [ + "ADC-R,N" "ADC" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ first2 swap curry ] action ; : ADC-R,R-instruction ( -- parser ) - "ADC-R,R" "ADC" complex-instruction - 8-bit-registers sp <&> - "," token <& - 8-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "ADC-R,R" "ADC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ first3 append swap curry ] action ; : ADC-R,(RR)-instruction ( -- parser ) - "ADC-R,(RR)" "ADC" complex-instruction - 8-bit-registers sp <&> - "," token <& - 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "ADC-R,(RR)" "ADC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ first3 append swap curry ] action ; : SBC-R,N-instruction ( -- parser ) - "SBC-R,N" "SBC" complex-instruction - 8-bit-registers sp <&> - ",n" token <& - just [ first2 swap curry ] <@ ; + [ + "SBC-R,N" "SBC" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ first2 swap curry ] action ; : SBC-R,R-instruction ( -- parser ) - "SBC-R,R" "SBC" complex-instruction - 8-bit-registers sp <&> - "," token <& - 8-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "SBC-R,R" "SBC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ first3 append swap curry ] action ; : SBC-R,(RR)-instruction ( -- parser ) - "SBC-R,(RR)" "SBC" complex-instruction - 8-bit-registers sp <&> - "," token <& - 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "SBC-R,(RR)" "SBC" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ first3 append swap curry ] action ; : SUB-R-instruction ( -- parser ) - "SUB-R" "SUB" complex-instruction - 8-bit-registers sp <&> - just [ first2 swap curry ] <@ ; + [ + "SUB-R" "SUB" complex-instruction , + 8-bit-registers sp , + ] seq* [ first2 swap curry ] action ; : SUB-(RR)-instruction ( -- parser ) - "SUB-(RR)" "SUB" complex-instruction - 16-bit-registers indirect sp <&> - just [ first2 swap curry ] <@ ; + [ + "SUB-(RR)" "SUB" complex-instruction , + 16-bit-registers indirect sp , + ] seq* [ first2 swap curry ] action ; : SUB-N-instruction ( -- parser ) - "SUB-N" "SUB" complex-instruction - "n" token sp <& - just [ { } clone swap curry ] <@ ; + [ + "SUB-N" "SUB" complex-instruction , + "n" token sp hide , + ] seq* [ first { } swap curry ] action ; : ADD-R,N-instruction ( -- parser ) - "ADD-R,N" "ADD" complex-instruction - 8-bit-registers sp <&> - ",n" token <& - just [ first2 swap curry ] <@ ; + [ + "ADD-R,N" "ADD" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ first2 swap curry ] action ; : ADD-R,R-instruction ( -- parser ) - "ADD-R,R" "ADD" complex-instruction - 8-bit-registers sp <&> - "," token <& - 8-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "ADD-R,R" "ADD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ first3 append swap curry ] action ; : ADD-RR,RR-instruction ( -- parser ) - "ADD-RR,RR" "ADD" complex-instruction - 16-bit-registers sp <&> - "," token <& - 16-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "ADD-RR,RR" "ADD" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ first3 append swap curry ] action ; : ADD-R,(RR)-instruction ( -- parser ) - "ADD-R,(RR)" "ADD" complex-instruction - 8-bit-registers sp <&> - "," token <& - 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "ADD-R,(RR)" "ADD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ first3 append swap curry ] action ; : LD-RR,NN-instruction ( -- parser ) #! LD BC,nn - "LD-RR,NN" "LD" complex-instruction - 16-bit-registers sp <&> - ",nn" token <& - just [ first2 swap curry ] <@ ; + [ + "LD-RR,NN" "LD" complex-instruction , + 16-bit-registers sp , + ",nn" token hide , + ] seq* [ first2 swap curry ] action ; : LD-R,N-instruction ( -- parser ) #! LD B,n - "LD-R,N" "LD" complex-instruction - 8-bit-registers sp <&> - ",n" token <& - just [ first2 swap curry ] <@ ; + [ + "LD-R,N" "LD" complex-instruction , + 8-bit-registers sp , + ",n" token hide , + ] seq* [ first2 swap curry ] action ; -: LD-(RR),N-instruction ( -- parser ) - "LD-(RR),N" "LD" complex-instruction - 16-bit-registers indirect sp <&> - ",n" token <& - just [ first2 swap curry ] <@ ; +: LD-(RR),N-instruction ( -- parser ) + [ + "LD-(RR),N" "LD" complex-instruction , + 16-bit-registers indirect sp , + ",n" token hide , + ] seq* [ first2 swap curry ] action ; : LD-(RR),R-instruction ( -- parser ) #! LD (BC),A - "LD-(RR),R" "LD" complex-instruction - 16-bit-registers indirect sp <&> - "," token <& - 8-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "LD-(RR),R" "LD" complex-instruction , + 16-bit-registers indirect sp , + "," token hide , + 8-bit-registers , + ] seq* [ first3 append swap curry ] action ; : LD-R,R-instruction ( -- parser ) - "LD-R,R" "LD" complex-instruction - 8-bit-registers sp <&> - "," token <& - 8-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "LD-R,R" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 8-bit-registers , + ] seq* [ first3 append swap curry ] action ; : LD-RR,RR-instruction ( -- parser ) - "LD-RR,RR" "LD" complex-instruction - 16-bit-registers sp <&> - "," token <& - 16-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "LD-RR,RR" "LD" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ first3 append swap curry ] action ; : LD-R,(RR)-instruction ( -- parser ) - "LD-R,(RR)" "LD" complex-instruction - 8-bit-registers sp <&> - "," token <& - 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "LD-R,(RR)" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + 16-bit-registers indirect , + ] seq* [ first3 append swap curry ] action ; : LD-(NN),RR-instruction ( -- parser ) - "LD-(NN),RR" "LD" complex-instruction - "nn" token indirect sp <& - "," token <& - 16-bit-registers <&> - just [ first2 swap curry ] <@ ; + [ + "LD-(NN),RR" "LD" complex-instruction , + "nn" token indirect sp hide , + "," token hide , + 16-bit-registers , + ] seq* [ first2 swap curry ] action ; : LD-(NN),R-instruction ( -- parser ) - "LD-(NN),R" "LD" complex-instruction - "nn" token indirect sp <& - "," token <& - 8-bit-registers <&> - just [ first2 swap curry ] <@ ; + [ + "LD-(NN),R" "LD" complex-instruction , + "nn" token indirect sp hide , + "," token hide , + 8-bit-registers , + ] seq* [ first2 swap curry ] action ; : LD-RR,(NN)-instruction ( -- parser ) - "LD-RR,(NN)" "LD" complex-instruction - 16-bit-registers sp <&> - "," token <& - "nn" token indirect <& - just [ first2 swap curry ] <@ ; + [ + "LD-RR,(NN)" "LD" complex-instruction , + 16-bit-registers sp , + "," token hide , + "nn" token indirect hide , + ] seq* [ first2 swap curry ] action ; : LD-R,(NN)-instruction ( -- parser ) - "LD-R,(NN)" "LD" complex-instruction - 8-bit-registers sp <&> - "," token <& - "nn" token indirect <& - just [ first2 swap curry ] <@ ; + [ + "LD-R,(NN)" "LD" complex-instruction , + 8-bit-registers sp , + "," token hide , + "nn" token indirect hide , + ] seq* [ first2 swap curry ] action ; : OUT-(N),R-instruction ( -- parser ) - "OUT-(N),R" "OUT" complex-instruction - "n" token indirect sp <& - "," token <& - 8-bit-registers <&> - just [ first2 swap curry ] <@ ; + [ + "OUT-(N),R" "OUT" complex-instruction , + "n" token indirect sp hide , + "," token hide , + 8-bit-registers , + ] seq* [ first2 swap curry ] action ; : IN-R,(N)-instruction ( -- parser ) - "IN-R,(N)" "IN" complex-instruction - 8-bit-registers sp <&> - "," token <& - "n" token indirect <& - just [ first2 swap curry ] <@ ; + [ + "IN-R,(N)" "IN" complex-instruction , + 8-bit-registers sp , + "," token hide , + "n" token indirect hide , + ] seq* [ first2 swap curry ] action ; : EX-(RR),RR-instruction ( -- parser ) - "EX-(RR),RR" "EX" complex-instruction - 16-bit-registers indirect sp <&> - "," token <& - 16-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "EX-(RR),RR" "EX" complex-instruction , + 16-bit-registers indirect sp , + "," token hide , + 16-bit-registers , + ] seq* [ first3 append swap curry ] action ; : EX-RR,RR-instruction ( -- parser ) - "EX-RR,RR" "EX" complex-instruction - 16-bit-registers sp <&> - "," token <& - 16-bit-registers <&> - just [ first2 swap first2 swap >r prepend r> curry ] <@ ; + [ + "EX-RR,RR" "EX" complex-instruction , + 16-bit-registers sp , + "," token hide , + 16-bit-registers , + ] seq* [ first3 append swap curry ] 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-R,N-instruction <|> - LD-R,R-instruction <|> - LD-RR,RR-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,N-instruction <|> - ADC-R,R-instruction <|> - ADC-R,(RR)-instruction <|> - ADD-R,N-instruction <|> - ADD-R,R-instruction <|> - ADD-RR,RR-instruction <|> - ADD-R,(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 <|> - just ; + [ + 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 some parse call ; + 8080-generator-parser parse ; SYMBOL: last-instruction SYMBOL: last-opcode From 38ae977befe096c4014e231d23d753dc5ce77e2d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 21:57:55 +1200 Subject: [PATCH 04/21] Cleanup some cpu-8080 code --- extra/cpu/8080/emulator/emulator.factor | 135 +++++++++++++----------- 1 file changed, 72 insertions(+), 63 deletions(-) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index d29ed23bf0..21392d43b1 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -798,6 +798,15 @@ SYMBOLS: $1 $2 $3 $4 ; #! 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 ; @@ -805,87 +814,87 @@ SYMBOLS: $1 $2 $3 $4 ; [ "RET-NN" "RET" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-0-instruction ( -- parser ) [ "RST-0" "RST" complex-instruction , "0" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-8-instruction ( -- parser ) [ "RST-8" "RST" complex-instruction , "8" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-10H-instruction ( -- parser ) [ "RST-10H" "RST" complex-instruction , "10H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-18H-instruction ( -- parser ) [ "RST-18H" "RST" complex-instruction , "18H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-20H-instruction ( -- parser ) [ "RST-20H" "RST" complex-instruction , "20H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-28H-instruction ( -- parser ) [ "RST-28H" "RST" complex-instruction , "28H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-30H-instruction ( -- parser ) [ "RST-30H" "RST" complex-instruction , "30H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-38H-instruction ( -- parser ) [ "RST-38H" "RST" complex-instruction , "38H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : JP-NN-instruction ( -- parser ) [ "JP-NN" "JP" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : JP-F|FF,NN-instruction ( -- parser ) [ "JP-F|FF,NN" "JP" complex-instruction , all-flags sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : JP-(RR)-instruction ( -- parser ) [ "JP-(RR)" "JP" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CALL-NN-instruction ( -- parser ) [ "CALL-NN" "CALL" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : CALL-F|FF,NN-instruction ( -- parser ) [ "CALL-F|FF,NN" "CALL" complex-instruction , all-flags sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; @@ -924,134 +933,134 @@ SYMBOLS: $1 $2 $3 $4 ; [ "DEC-R" "DEC" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : DEC-RR-instruction ( -- parser ) [ "DEC-RR" "DEC" complex-instruction , 16-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : DEC-(RR)-instruction ( -- parser ) [ "DEC-(RR)" "DEC" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : POP-RR-instruction ( -- parser ) [ "POP-RR" "POP" complex-instruction , all-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : PUSH-RR-instruction ( -- parser ) [ "PUSH-RR" "PUSH" complex-instruction , all-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-R-instruction ( -- parser ) [ "INC-R" "INC" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-RR-instruction ( -- parser ) [ "INC-RR" "INC" complex-instruction , 16-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-(RR)-instruction ( -- parser ) [ "INC-(RR)" "INC" complex-instruction , all-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : RET-F|FF-instruction ( -- parser ) [ "RET-F|FF" "RET" complex-instruction , all-flags sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : AND-N-instruction ( -- parser ) [ "AND-N" "AND" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : AND-R-instruction ( -- parser ) [ "AND-R" "AND" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : AND-(RR)-instruction ( -- parser ) [ "AND-(RR)" "AND" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : XOR-N-instruction ( -- parser ) [ "XOR-N" "XOR" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : XOR-R-instruction ( -- parser ) [ "XOR-R" "XOR" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : XOR-(RR)-instruction ( -- parser ) [ "XOR-(RR)" "XOR" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OR-N-instruction ( -- parser ) [ "OR-N" "OR" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : OR-R-instruction ( -- parser ) [ "OR-R" "OR" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OR-(RR)-instruction ( -- parser ) [ "OR-(RR)" "OR" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CP-N-instruction ( -- parser ) [ "CP-N" "CP" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : CP-R-instruction ( -- parser ) [ "CP-R" "CP" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CP-(RR)-instruction ( -- parser ) [ "CP-(RR)" "CP" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADC-R,N-instruction ( -- parser ) [ "ADC-R,N" "ADC" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADC-R,R-instruction ( -- parser ) [ @@ -1059,7 +1068,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADC-R,(RR)-instruction ( -- parser ) [ @@ -1067,14 +1076,14 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SBC-R,N-instruction ( -- parser ) [ "SBC-R,N" "SBC" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SBC-R,R-instruction ( -- parser ) [ @@ -1082,7 +1091,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SBC-R,(RR)-instruction ( -- parser ) [ @@ -1090,32 +1099,32 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SUB-R-instruction ( -- parser ) [ "SUB-R" "SUB" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SUB-(RR)-instruction ( -- parser ) [ "SUB-(RR)" "SUB" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SUB-N-instruction ( -- parser ) [ "SUB-N" "SUB" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : ADD-R,N-instruction ( -- parser ) [ "ADD-R,N" "ADD" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADD-R,R-instruction ( -- parser ) [ @@ -1123,7 +1132,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADD-RR,RR-instruction ( -- parser ) [ @@ -1131,7 +1140,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADD-R,(RR)-instruction ( -- parser ) [ @@ -1139,7 +1148,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-RR,NN-instruction ( -- parser ) #! LD BC,nn @@ -1147,7 +1156,7 @@ SYMBOLS: $1 $2 $3 $4 ; "LD-RR,NN" "LD" complex-instruction , 16-bit-registers sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-R,N-instruction ( -- parser ) #! LD B,n @@ -1155,14 +1164,14 @@ SYMBOLS: $1 $2 $3 $4 ; "LD-R,N" "LD" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(RR),N-instruction ( -- parser ) [ "LD-(RR),N" "LD" complex-instruction , 16-bit-registers indirect sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(RR),R-instruction ( -- parser ) #! LD (BC),A @@ -1171,7 +1180,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers indirect sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-R,R-instruction ( -- parser ) [ @@ -1179,7 +1188,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-RR,RR-instruction ( -- parser ) [ @@ -1187,7 +1196,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-R,(RR)-instruction ( -- parser ) [ @@ -1195,7 +1204,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-(NN),RR-instruction ( -- parser ) [ @@ -1203,7 +1212,7 @@ SYMBOLS: $1 $2 $3 $4 ; "nn" token indirect sp hide , "," token hide , 16-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(NN),R-instruction ( -- parser ) [ @@ -1211,7 +1220,7 @@ SYMBOLS: $1 $2 $3 $4 ; "nn" token indirect sp hide , "," token hide , 8-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-RR,(NN)-instruction ( -- parser ) [ @@ -1219,7 +1228,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , "nn" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-R,(NN)-instruction ( -- parser ) [ @@ -1227,7 +1236,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , "nn" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OUT-(N),R-instruction ( -- parser ) [ @@ -1235,7 +1244,7 @@ SYMBOLS: $1 $2 $3 $4 ; "n" token indirect sp hide , "," token hide , 8-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : IN-R,(N)-instruction ( -- parser ) [ @@ -1243,7 +1252,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , "n" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : EX-(RR),RR-instruction ( -- parser ) [ @@ -1251,7 +1260,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers indirect sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : EX-RR,RR-instruction ( -- parser ) [ @@ -1259,7 +1268,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : 8080-generator-parser ( -- parser ) [ From 51faed0945341b4f0b4e3b6d0c50588ba0651de4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 22:52:15 +1200 Subject: [PATCH 05/21] Make pegs seq parser use short circuiting && --- extra/peg/peg.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 868072efa5..d1302107ea 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle debugger io vectors arrays math.parser math.order vectors combinators combinators.lib - combinators.short-circuit classes sets unicode.categories compiler.units parser - words quotations effects memoize accessors locals effects splitting ; + classes sets unicode.categories compiler.units parser + words quotations effects memoize accessors locals effects splitting + combinators.short-circuit combinators.short-circuit.smart ; IN: peg USE: prettyprint @@ -410,8 +411,10 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % - parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ - compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each + [ + parsers>> unclip compiled-parser 1quotation [ parse-seq-element ] curry , + [ compiled-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each + ] { } make , \ && , ] [ ] make ; TUPLE: choice-parser parsers ; From 46b0df263138251239af63ea75034e4c5ba8b90a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 23:09:29 +1200 Subject: [PATCH 06/21] Use || in peg choice code generation --- extra/peg/peg.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index d1302107ea..eec4007c02 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -421,9 +421,10 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) [ - f , - parsers>> [ compiled-parser ] map - unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each + [ + parsers>> [ compiled-parser ] map + unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each + ] { } make , \ || , ] [ ] make ; TUPLE: repeat0-parser p1 ; From 9fc2175403a4108f90f6593aaac53a82b114d597 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 02:27:28 +1200 Subject: [PATCH 07/21] peg refactorings --- extra/peg/parsers/parsers.factor | 2 +- extra/peg/peg.factor | 38 ++++++++++++++++++-------------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index f6c2820ac2..b5b2886a5e 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -17,7 +17,7 @@ TUPLE: just-parser p1 ; M: just-parser (compile) ( parser -- quot ) - just-parser-p1 compiled-parser just-pattern curry ; + just-parser-p1 compile-parser just-pattern curry ; : just ( parser -- parser ) just-parser boa wrap-peg ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index eec4007c02..147e5b892e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -280,7 +280,13 @@ GENERIC: (compile) ( peg -- quot ) gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd id>> "peg-id" set-word-prop [ execute-parser ] curry ; -: compiled-parser ( parser -- word ) +: preset-parser-word ( parser -- parser word ) + gensym [ >>compiled ] keep ; + +: define-parser-word ( parser word -- ) + swap parser-body (( -- result )) define-declared ; + +: compile-parser ( parser -- word ) #! Look to see if the given parser has been compiled. #! If not, compile it to a temporary word, cache it, #! and return it. Otherwise return the existing one. @@ -290,7 +296,7 @@ GENERIC: (compile) ( peg -- quot ) dup compiled>> [ nip ] [ - gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop + preset-parser-word [ define-parser-word ] keep ] if* ; SYMBOL: delayed @@ -299,13 +305,13 @@ SYMBOL: delayed #! Work through all delayed parsers and recompile their #! words to have the correct bodies. delayed get [ - call compiled-parser 1quotation 0 1 define-declared + call compile-parser 1quotation 0 1 define-declared ] assoc-each ; : compile ( parser -- word ) [ H{ } clone delayed [ - compiled-parser fixup-delayed + compile-parser fixup-delayed ] with-variable ] with-compilation-unit ; @@ -412,8 +418,8 @@ M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % [ - parsers>> unclip compiled-parser 1quotation [ parse-seq-element ] curry , - [ compiled-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each + parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , + [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each ] { } make , \ && , ] [ ] make ; @@ -422,7 +428,7 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) [ [ - parsers>> [ compiled-parser ] map + parsers>> [ compile-parser ] map unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each ] { } make , \ || , ] [ ] make ; @@ -439,7 +445,7 @@ TUPLE: repeat0-parser p1 ; ] if* ; inline M: repeat0-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ + p1>> compile-parser 1quotation '[ input-slice V{ } clone , swap (repeat) ] ; @@ -453,7 +459,7 @@ TUPLE: repeat1-parser p1 ; ] if* ; M: repeat1-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ + p1>> compile-parser 1quotation '[ input-slice V{ } clone , swap (repeat) repeat1-empty-check ] ; @@ -463,7 +469,7 @@ TUPLE: optional-parser p1 ; [ input-slice f ] unless* ; M: optional-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ @ check-optional ] ; + p1>> compile-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; @@ -475,7 +481,7 @@ TUPLE: semantic-parser p1 quot ; ] if ; inline M: semantic-parser (compile) ( peg -- quot ) - [ p1>> compiled-parser 1quotation ] [ quot>> ] bi + [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-semantic ] ; TUPLE: ensure-parser p1 ; @@ -484,7 +490,7 @@ TUPLE: ensure-parser p1 ; [ ignore ] [ drop f ] if ; M: ensure-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; + p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; @@ -492,7 +498,7 @@ TUPLE: ensure-not-parser p1 ; [ drop f ] [ ignore ] if ; M: ensure-not-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; + p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; @@ -504,7 +510,7 @@ TUPLE: action-parser p1 quot ; ] if ; inline M: action-parser (compile) ( peg -- quot ) - [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; + [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -516,7 +522,7 @@ M: action-parser (compile) ( peg -- quot ) TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ + p1>> compile-parser 1quotation '[ input-slice left-trim-slice input-from pos set @ ] ; @@ -535,7 +541,7 @@ M: box-parser (compile) ( peg -- quot ) #! to produce the parser to be compiled. #! This differs from 'delay' which calls #! it at run time. - quot>> call compiled-parser 1quotation ; + quot>> call compile-parser 1quotation ; PRIVATE> From 14cc510844e8dea99580eb1e532d06cb73943c40 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:23:03 +1200 Subject: [PATCH 08/21] Fix fjsc failing tests --- extra/fjsc/fjsc-tests.factor | 22 ++++++------ extra/fjsc/fjsc.factor | 68 ++++++++++++++++++------------------ 2 files changed, 45 insertions(+), 45 deletions(-) diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ce968128be..766e2ec60c 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -4,31 +4,31 @@ USING: kernel tools.test peg fjsc ; IN: fjsc.tests { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "55 2abc1 100" 'expression' parse parse-result-ast + "55 2abc1 100" 'expression' parse ] unit-test { T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast + "[ 55 2abc1 100 ]" 'quotation' parse ] unit-test { T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "{ 55 2abc1 100 }" 'array' parse parse-result-ast + "{ 55 2abc1 100 }" 'array' parse ] unit-test { T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [ - "( -- d e f )" 'stack-effect' parse parse-result-ast + "( -- d e f )" 'stack-effect' parse ] unit-test { T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [ - "( a b c -- d e f )" 'stack-effect' parse parse-result-ast + "( a b c -- d e f )" 'stack-effect' parse ] unit-test { T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [ - "( a b c -- )" 'stack-effect' parse parse-result-ast + "( a b c -- )" 'stack-effect' parse ] unit-test { T{ ast-stack-effect f V{ } V{ } } } [ - "( -- )" 'stack-effect' parse parse-result-ast + "( -- )" 'stack-effect' parse ] unit-test { f } [ @@ -37,18 +37,18 @@ IN: fjsc.tests { T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [ - "\"abcd\"" 'statement' parse parse-result-ast + "\"abcd\"" 'statement' parse ] unit-test { T{ ast-expression f V{ T{ ast-use f "foo" } } } } [ - "USE: foo" 'statement' parse parse-result-ast + "USE: foo" 'statement' parse ] unit-test { T{ ast-expression f V{ T{ ast-in f "foo" } } } } [ - "IN: foo" 'statement' parse parse-result-ast + "IN: foo" 'statement' parse ] unit-test { T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [ - "USING: foo bar ;" 'statement' parse parse-result-ast + "USING: foo bar ;" 'statement' parse ] unit-test diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index ec3d92f78b..ecefd862d3 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io -io.streams.string assocs memoize ascii peg.parsers ; +io.streams.string assocs ascii peg.parsers ; IN: fjsc TUPLE: ast-number value ; @@ -41,7 +41,7 @@ C: ast-hashtable digit? not and and ; -MEMO: 'identifier-ends' ( -- parser ) +: 'identifier-ends' ( -- parser ) [ [ blank? not ] keep [ CHAR: " = not ] keep @@ -52,22 +52,22 @@ MEMO: 'identifier-ends' ( -- parser ) and and and and and ] satisfy repeat0 ; -MEMO: 'identifier-middle' ( -- parser ) +: 'identifier-middle' ( -- parser ) [ identifier-middle? ] satisfy repeat1 ; -MEMO: 'identifier' ( -- parser ) +: 'identifier' ( -- parser ) [ 'identifier-ends' , 'identifier-middle' , 'identifier-ends' , - ] { } make seq [ + ] seq* [ concat >string f ] action ; DEFER: 'expression' -MEMO: 'effect-name' ( -- parser ) +: 'effect-name' ( -- parser ) [ [ blank? not ] keep [ CHAR: ) = not ] keep @@ -75,98 +75,98 @@ MEMO: 'effect-name' ( -- parser ) and and ] satisfy repeat1 [ >string ] action ; -MEMO: 'stack-effect' ( -- parser ) +: 'stack-effect' ( -- parser ) [ "(" token hide , 'effect-name' sp repeat0 , "--" token sp hide , 'effect-name' sp repeat0 , ")" token sp hide , - ] { } make seq [ + ] seq* [ first2 ] action ; -MEMO: 'define' ( -- parser ) +: 'define' ( -- parser ) [ ":" token sp hide , 'identifier' sp [ ast-identifier-value ] action , 'stack-effect' sp optional , 'expression' , ";" token sp hide , - ] { } make seq [ first3 ] action ; + ] seq* [ first3 ] action ; -MEMO: 'quotation' ( -- parser ) +: 'quotation' ( -- parser ) [ "[" token sp hide , 'expression' [ ast-expression-values ] action , "]" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'array' ( -- parser ) +: 'array' ( -- parser ) [ "{" token sp hide , 'expression' [ ast-expression-values ] action , "}" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'word' ( -- parser ) +: 'word' ( -- parser ) [ "\\" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value f ] action ; + ] seq* [ first ast-identifier-value f ] action ; -MEMO: 'atom' ( -- parser ) +: 'atom' ( -- parser ) [ 'identifier' , 'integer' [ ] action , 'string' [ ] action , - ] { } make choice ; + ] choice* ; -MEMO: 'comment' ( -- parser ) +: 'comment' ( -- parser ) [ [ "#!" token sp , "!" token sp , - ] { } make choice hide , + ] choice* hide , [ dup CHAR: \n = swap CHAR: \r = or not ] satisfy repeat0 , - ] { } make seq [ drop ] action ; + ] seq* [ drop ] action ; -MEMO: 'USE:' ( -- parser ) +: 'USE:' ( -- parser ) [ "USE:" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value ] action ; + ] seq* [ first ast-identifier-value ] action ; -MEMO: 'IN:' ( -- parser ) +: 'IN:' ( -- parser ) [ "IN:" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value ] action ; + ] seq* [ first ast-identifier-value ] action ; -MEMO: 'USING:' ( -- parser ) +: 'USING:' ( -- parser ) [ "USING:" token sp hide , 'identifier' sp [ ast-identifier-value ] action repeat1 , ";" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'hashtable' ( -- parser ) +: 'hashtable' ( -- parser ) [ "H{" token sp hide , 'expression' [ ast-expression-values ] action , "}" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'parsing-word' ( -- parser ) +: 'parsing-word' ( -- parser ) [ 'USE:' , 'USING:' , 'IN:' , - ] { } make choice ; + ] choice* ; -MEMO: 'expression' ( -- parser ) +: 'expression' ( -- parser ) [ [ 'comment' , @@ -177,10 +177,10 @@ MEMO: 'expression' ( -- parser ) 'hashtable' sp , 'word' sp , 'atom' sp , - ] { } make choice repeat0 [ ] action + ] choice* repeat0 [ ] action ] delay ; -MEMO: 'statement' ( -- parser ) +: 'statement' ( -- parser ) 'expression' ; GENERIC: (compile) ( ast -- ) From 8208661ed806ebe97966ee196974ca024674c1d4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:28:47 +1200 Subject: [PATCH 09/21] Use new style accessors in fjsc --- extra/fjsc/fjsc.factor | 119 ++++++++++++++++++----------------------- 1 file changed, 52 insertions(+), 67 deletions(-) diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index ecefd862d3..5f1f977d20 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel peg strings promises sequences math +USING: accessors kernel peg strings sequences math math.parser namespaces words quotations arrays hashtables io -io.streams.string assocs ascii peg.parsers ; +io.streams.string assocs ascii peg.parsers accessors ; IN: fjsc TUPLE: ast-number value ; @@ -20,21 +20,6 @@ TUPLE: ast-using names ; TUPLE: ast-in name ; TUPLE: ast-hashtable elements ; -C: ast-number -C: ast-identifier -C: ast-string -C: ast-quotation -C: ast-array -C: ast-define -C: ast-expression -C: ast-word -C: ast-comment -C: ast-stack-effect -C: ast-use -C: ast-using -C: ast-in -C: ast-hashtable - : identifier-middle? ( ch -- bool ) [ blank? not ] keep [ "}];\"" member? not ] keep @@ -61,7 +46,7 @@ C: ast-hashtable 'identifier-middle' , 'identifier-ends' , ] seq* [ - concat >string f + concat >string f ast-identifier boa ] action ; @@ -83,43 +68,43 @@ DEFER: 'expression' 'effect-name' sp repeat0 , ")" token sp hide , ] seq* [ - first2 + first2 ast-stack-effect boa ] action ; : 'define' ( -- parser ) [ ":" token sp hide , - 'identifier' sp [ ast-identifier-value ] action , + 'identifier' sp [ value>> ] action , 'stack-effect' sp optional , 'expression' , ";" token sp hide , - ] seq* [ first3 ] action ; + ] seq* [ first3 ast-define boa ] action ; : 'quotation' ( -- parser ) [ "[" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "]" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-quotation boa ] action ; : 'array' ( -- parser ) [ "{" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "}" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-array boa ] action ; : 'word' ( -- parser ) [ "\\" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value f ] action ; + ] seq* [ first value>> f ast-word boa ] action ; : 'atom' ( -- parser ) [ 'identifier' , - 'integer' [ ] action , - 'string' [ ] action , + 'integer' [ ast-number boa ] action , + 'string' [ ast-string boa ] action , ] choice* ; : 'comment' ( -- parser ) @@ -131,33 +116,33 @@ DEFER: 'expression' [ dup CHAR: \n = swap CHAR: \r = or not ] satisfy repeat0 , - ] seq* [ drop ] action ; + ] seq* [ drop ast-comment boa ] action ; : 'USE:' ( -- parser ) [ "USE:" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value ] action ; + ] seq* [ first value>> ast-use boa ] action ; : 'IN:' ( -- parser ) [ "IN:" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value ] action ; + ] seq* [ first value>> ast-in boa ] action ; : 'USING:' ( -- parser ) [ "USING:" token sp hide , - 'identifier' sp [ ast-identifier-value ] action repeat1 , + 'identifier' sp [ value>> ] action repeat1 , ";" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-using boa ] action ; : 'hashtable' ( -- parser ) [ "H{" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "}" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-hashtable boa ] action ; : 'parsing-word' ( -- parser ) [ @@ -177,7 +162,7 @@ DEFER: 'expression' 'hashtable' sp , 'word' sp , 'atom' sp , - ] choice* repeat0 [ ] action + ] choice* repeat0 [ ast-expression boa ] action ] delay ; : 'statement' ( -- parser ) @@ -187,7 +172,7 @@ GENERIC: (compile) ( ast -- ) GENERIC: (literal) ( ast -- ) M: ast-number (literal) - ast-number-value number>string , ; + value>> number>string , ; M: ast-number (compile) "factor.push_data(" , @@ -196,7 +181,7 @@ M: ast-number (compile) M: ast-string (literal) "\"" , - ast-string-value , + value>> , "\"" , ; M: ast-string (compile) @@ -205,14 +190,14 @@ M: ast-string (compile) "," , ; M: ast-identifier (literal) - dup ast-identifier-vocab [ + dup vocab>> [ "factor.get_word(\"" , - dup ast-identifier-vocab , + dup vocab>> , "\",\"" , - ast-identifier-value , + value>> , "\")" , ] [ - "factor.find_word(\"" , ast-identifier-value , "\")" , + "factor.find_word(\"" , value>> , "\")" , ] if ; M: ast-identifier (compile) @@ -220,9 +205,9 @@ M: ast-identifier (compile) M: ast-define (compile) "factor.define_word(\"" , - dup ast-define-name , + dup name>> , "\",\"source\"," , - ast-define-expression (compile) + expression>> (compile) "," , ; : do-expressions ( seq -- ) @@ -242,17 +227,17 @@ M: ast-define (compile) M: ast-quotation (literal) "factor.make_quotation(\"source\"," , - ast-quotation-values do-expressions + values>> do-expressions ")" , ; M: ast-quotation (compile) "factor.push_data(factor.make_quotation(\"source\"," , - ast-quotation-values do-expressions + values>> do-expressions ")," , ; M: ast-array (literal) "[" , - ast-array-elements [ "," , ] [ (literal) ] interleave + elements>> [ "," , ] [ (literal) ] interleave "]" , ; M: ast-array (compile) @@ -260,7 +245,7 @@ M: ast-array (compile) M: ast-hashtable (literal) "new Hashtable().fromAlist([" , - ast-hashtable-elements [ "," , ] [ (literal) ] interleave + elements>> [ "," , ] [ (literal) ] interleave "])" , ; M: ast-hashtable (compile) @@ -268,22 +253,22 @@ M: ast-hashtable (compile) M: ast-expression (literal) - ast-expression-values [ + values>> [ (literal) ] each ; M: ast-expression (compile) - ast-expression-values do-expressions ; + values>> do-expressions ; M: ast-word (literal) - dup ast-word-vocab [ + dup vocab>> [ "factor.get_word(\"" , - dup ast-word-vocab , + dup vocab>> , "\",\"" , - ast-word-value , + value>> , "\")" , ] [ - "factor.find_word(\"" , ast-word-value , "\")" , + "factor.find_word(\"" , value>> , "\")" , ] if ; M: ast-word (compile) @@ -299,17 +284,17 @@ M: ast-stack-effect (compile) M: ast-use (compile) "factor.use(\"" , - ast-use-name , + name>> , "\"," , ; M: ast-in (compile) "factor.set_in(\"" , - ast-in-name , + name>> , "\"," , ; M: ast-using (compile) "factor.using([" , - ast-using-names [ + names>> [ "," , ] [ "\"" , , "\"" , @@ -319,34 +304,34 @@ M: ast-using (compile) GENERIC: (parse-factor-quotation) ( object -- ast ) M: number (parse-factor-quotation) ( object -- ast ) - ; + ast-number boa ; M: symbol (parse-factor-quotation) ( object -- ast ) - dup >string swap vocabulary>> ; + dup >string swap vocabulary>> ast-identifier boa ; M: word (parse-factor-quotation) ( object -- ast ) - dup name>> swap vocabulary>> ; + dup name>> swap vocabulary>> ast-identifier boa ; M: string (parse-factor-quotation) ( object -- ast ) - ; + ast-string boa ; M: quotation (parse-factor-quotation) ( object -- ast ) [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-quotation boa ; M: array (parse-factor-quotation) ( object -- ast ) [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-array boa ; M: hashtable (parse-factor-quotation) ( object -- ast ) >alist [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-hashtable boa ; M: wrapper (parse-factor-quotation) ( object -- ast ) - wrapped>> dup name>> swap vocabulary>> ; + wrapped>> dup name>> swap vocabulary>> ast-word boa ; GENERIC: fjsc-parse ( object -- ast ) @@ -356,7 +341,7 @@ M: string fjsc-parse ( object -- ast ) M: quotation fjsc-parse ( object -- ast ) [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-expression boa ; : fjsc-compile ( ast -- string ) [ @@ -372,7 +357,7 @@ M: quotation fjsc-parse ( object -- ast ) : fc* ( string -- string ) [ - 'statement' parse parse-result-ast ast-expression-values do-expressions + 'statement' parse parse-result-ast values>> do-expressions ] { } make [ write ] each ; From d808d49f68beef9d37ae647e82eb998b1fe1b933 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:33:09 +1200 Subject: [PATCH 10/21] Fix lisp.parser unit tests --- extra/lisp/parser/parser-tests.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 4aa8154690..d722390f9a 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -5,43 +5,43 @@ USING: lisp.parser tools.test peg peg.ebnf lists ; IN: lisp.parser.tests { 1234 } [ - "1234" "atom" \ lisp-expr rule parse parse-result-ast + "1234" "atom" \ lisp-expr rule parse ] unit-test { -42 } [ - "-42" "atom" \ lisp-expr rule parse parse-result-ast + "-42" "atom" \ lisp-expr rule parse ] unit-test { 37/52 } [ - "37/52" "atom" \ lisp-expr rule parse parse-result-ast + "37/52" "atom" \ lisp-expr rule parse ] unit-test { 123.98 } [ - "123.98" "atom" \ lisp-expr rule parse parse-result-ast + "123.98" "atom" \ lisp-expr rule parse ] unit-test { "" } [ - "\"\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"\"" "atom" \ lisp-expr rule parse ] unit-test { "aoeu" } [ - "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\"" "atom" \ lisp-expr rule parse ] unit-test { "aoeu\"de" } [ - "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse ] unit-test { T{ lisp-symbol f "foobar" } } [ - "foobar" "atom" \ lisp-expr rule parse parse-result-ast + "foobar" "atom" \ lisp-expr rule parse ] unit-test { T{ lisp-symbol f "+" } } [ - "+" "atom" \ lisp-expr rule parse parse-result-ast + "+" "atom" \ lisp-expr rule parse ] unit-test { +nil+ } [ - "()" lisp-expr parse-result-ast + "()" lisp-expr ] unit-test { T{ @@ -54,7 +54,7 @@ IN: lisp.parser.tests 1 T{ cons f 2 T{ cons f "aoeu" +nil+ } } } } } [ - "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast + "(foo 1 2 \"aoeu\")" lisp-expr ] unit-test { T{ cons f @@ -64,5 +64,5 @@ IN: lisp.parser.tests T{ cons f 2 +nil+ } } } } [ - "(1 (3 4) 2)" lisp-expr parse-result-ast + "(1 (3 4) 2)" lisp-expr ] unit-test \ No newline at end of file From 59857a455b3e072633f15a895ce66ff49b1082d2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:34:12 +1200 Subject: [PATCH 11/21] Fix lisp unit tests --- extra/lisp/lisp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 1dd285ed7c..bc425df12c 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -99,7 +99,7 @@ PRIVATE> uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast compile-form ; + lisp-expr compile-form ; : lisp-eval ( str -- * ) lisp-string>factor call ; From 78c3b25f600e9eab68277e824636c266f6e126fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Jul 2008 20:32:17 -0500 Subject: [PATCH 12/21] UI inheritance conversion step 1: eliminate all usages of set-gadget-delegate except build-* and some contributed vocabs --- extra/color-picker/color-picker.factor | 4 +- extra/slides/slides.factor | 10 +-- extra/ui/cocoa/cocoa.factor | 16 ++-- extra/ui/cocoa/views/views.factor | 11 +-- extra/ui/gadgets/books/books.factor | 13 ++- extra/ui/gadgets/borders/borders.factor | 13 +-- extra/ui/gadgets/buttons/buttons-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons.factor | 75 ++++++++-------- extra/ui/gadgets/canvas/canvas.factor | 4 +- extra/ui/gadgets/editors/editors.factor | 88 +++++++++---------- extra/ui/gadgets/frames/frames.factor | 8 +- extra/ui/gadgets/gadgets-docs.factor | 39 +------- extra/ui/gadgets/gadgets-tests.factor | 9 +- extra/ui/gadgets/gadgets.factor | 25 +++--- extra/ui/gadgets/grids/grids.factor | 34 +++---- .../ui/gadgets/incremental/incremental.factor | 17 ++-- .../ui/gadgets/labelled/labelled-tests.factor | 27 ------ extra/ui/gadgets/labelled/labelled.factor | 5 -- extra/ui/gadgets/labels/labels.factor | 18 ++-- extra/ui/gadgets/lists/lists.factor | 27 +++--- extra/ui/gadgets/menus/menus.factor | 4 +- extra/ui/gadgets/packs/packs.factor | 18 ++-- extra/ui/gadgets/panes/panes.factor | 29 +++--- extra/ui/gadgets/paragraphs/paragraphs.factor | 4 +- .../presentations/presentations.factor | 17 ++-- extra/ui/gadgets/scrollers/scrollers.factor | 27 +++--- extra/ui/gadgets/sliders/sliders.factor | 23 ++--- extra/ui/gadgets/slots/slots.factor | 23 +++-- extra/ui/gadgets/status-bar/status-bar.factor | 12 +-- extra/ui/gadgets/tracks/tracks.factor | 18 ++-- extra/ui/gadgets/viewports/viewports.factor | 13 +-- extra/ui/gadgets/worlds/worlds-docs.factor | 18 ++-- extra/ui/gadgets/worlds/worlds-tests.factor | 10 +-- extra/ui/gadgets/worlds/worlds.factor | 32 +++---- extra/ui/gadgets/wrappers/wrappers.factor | 22 +++++ extra/ui/gestures/gestures.factor | 2 +- extra/ui/render/render-docs.factor | 6 +- extra/ui/tools/interactor/interactor.factor | 14 +-- extra/ui/tools/listener/listener.factor | 2 +- extra/ui/tools/search/search.factor | 4 +- extra/ui/tools/tools.factor | 6 +- extra/ui/tools/traceback/traceback.factor | 22 ++--- extra/ui/tools/workspace/workspace.factor | 4 +- extra/ui/ui-docs.factor | 6 +- extra/ui/ui.factor | 1 - extra/ui/windows/windows.factor | 4 +- extra/ui/x11/x11.factor | 4 +- 47 files changed, 377 insertions(+), 413 deletions(-) delete mode 100644 extra/ui/gadgets/labelled/labelled-tests.factor create mode 100644 extra/ui/gadgets/wrappers/wrappers.factor diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index b494dbc188..99968ca3c3 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -11,10 +11,10 @@ IN: color-picker : ( model -- gadget ) 1 over set-slider-line ; -TUPLE: color-preview ; +TUPLE: color-preview < gadget ; : ( model -- gadget ) - color-preview construct-control + color-preview new-gadget { 100 100 } over set-rect-dim ; M: color-preview model-changed diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 1c8b4fcbb3..61829e5936 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables help.markup help.stylesheet io io.styles kernel math models namespaces sequences ui ui.gadgets ui.gadgets.books ui.gadgets.panes ui.gestures ui.render @@ -70,12 +72,10 @@ IN: slides $divider $list ; -TUPLE: slides ; +TUPLE: slides < book ; : ( slides -- gadget ) - [ ] map 0 - slides construct-gadget - [ set-gadget-delegate ] keep ; + [ ] map 0 slides new-book ; : change-page ( book n -- ) over control-value + over gadget-children length rem @@ -103,5 +103,3 @@ TUPLE: slides ; : slides-window ( slides -- ) [ "Slides" open-window ] with-ui ; - -MAIN: slides-window diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index b0653ffa39..bf28740ecc 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math arrays cocoa cocoa.application command-line -kernel memory namespaces cocoa.messages cocoa.runtime -cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows -cocoa.classes cocoa.application sequences system ui ui.backend -ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views -core-foundation threads ; +USING: accessors math arrays cocoa cocoa.application +command-line kernel memory namespaces cocoa.messages +cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types +cocoa.windows cocoa.classes cocoa.application sequences system +ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds +ui.cocoa.views core-foundation threads ; IN: ui.cocoa TUPLE: handle view window ; @@ -38,7 +38,7 @@ M: pasteboard set-clipboard-contents selection set-global ; : world>NSRect ( world -- NSRect ) - dup world-loc first2 rot rect-dim first2 ; + dup window-loc>> first2 rot rect-dim first2 ; : gadget-window ( world -- ) [ @@ -68,7 +68,7 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) world-handle handle-view -> isInFullScreenMode zero? not ; : auto-position ( world -- ) - dup world-loc { 0 0 } = [ + dup window-loc>> { 0 0 } = [ world-handle handle-window -> center ] [ drop diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 20e6e19de5..68db5954d5 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages -cocoa.subclassing cocoa.classes cocoa.views cocoa.application -cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets -ui.gadgets.worlds ui.gestures core-foundation threads combinators ; +USING: accessors alien alien.c-types arrays assocs cocoa kernel +math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views +cocoa.application cocoa.pasteboard cocoa.types cocoa.windows +sequences ui ui.gadgets ui.gadgets.worlds ui.gestures +core-foundation threads combinators ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) @@ -377,7 +378,7 @@ CLASS: { [ 2nip -> object dup window-content-rect NSRect-x-y 2array - swap -> contentView window set-world-loc + swap -> contentView window (>>window-loc) ] } diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 92520e0266..219a970943 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences models ui.gadgets ; +USING: accessors kernel sequences models ui.gadgets ; IN: ui.gadgets.books -TUPLE: book ; +TUPLE: book < gadget ; : hide-all ( book -- ) gadget-children [ hide-gadget ] each ; @@ -16,8 +16,13 @@ M: book model-changed dup current-page show-gadget relayout ; +: new-book ( pages model class -- book ) + new-gadget + swap >>model + [ add-gadgets ] keep ; inline + : ( pages model -- book ) - book construct-control [ add-gadgets ] keep ; + book new-book ; M: book pref-dim* gadget-children pref-dims max-dim ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 91d20e9c99..ce7ea32008 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -1,15 +1,16 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays ui.gadgets generic hashtables kernel math +USING: accessors arrays ui.gadgets kernel math namespaces vectors sequences math.vectors ; IN: ui.gadgets.borders -TUPLE: border size fill ; +TUPLE: border < gadget size fill ; : ( child gap -- border ) - dup 2array { 0 0 } border boa - over set-delegate - tuck add-gadget ; + border new-gadget + swap dup 2array >>size + { 0 0 } >>fill + [ add-gadget ] keep ; M: border pref-dim* [ border-size 2 v*n ] keep diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 6c5d757dd4..94801145e3 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -16,7 +16,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set [ 2 ] [ "t" get gadget-children length ] unit-test -[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test +[ "Foo A" ] [ "t" get gadget-child gadget-child gadget-child label-string ] unit-test [ ] [ 2 { diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index c36d2050c9..ab71081c87 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.labels ui.gadgets.theme +USING: accessors arrays kernel math models namespaces sequences +strings quotations assocs combinators classes colors +classes.tuple opengl math.vectors +ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.labels ui.gadgets.theme ui.gadgets.wrappers ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render kernel math models namespaces sequences strings -quotations assocs combinators classes colors classes.tuple -opengl math.vectors ; +ui.render ; IN: ui.gadgets.buttons -TUPLE: button pressed? selected? quot ; +TUPLE: button < wrapper pressed? selected? quot ; : buttons-down? ( -- ? ) hand-buttons get-global empty? not ; @@ -39,10 +40,13 @@ button H{ { T{ mouse-enter } [ button-update ] } } set-gestures +: new-button ( label quot class -- button ) + new-gadget + swap >>quot + [ >r >label r> add-gadget ] keep ; inline + :