diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 276dd581c5..edda9e7fdb 100755 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,6 +2,12 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; +\ expand-constants must-infer + +: xyz 123 ; + +[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test + : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; [ 123 ] [ foo ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index c553ca5cfb..a9b39f80ab 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects ; +accessors combinators effects continuations ; IN: alien.c-types DEFER: @@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- ) } 2cleave ; : expand-constants ( c-type -- c-type' ) - #! We use def>> call instead of execute to get around - #! staging violations dup array? [ - unclip >r [ dup word? [ def>> call ] when ] map r> prefix + unclip >r [ + dup word? [ + def>> { } swap with-datastack first + ] when + ] map r> prefix ] when ; : malloc-file-contents ( path -- alien len ) binary file-contents dup malloc-byte-array swap length ; +: if-void ( type true false -- ) + pick "void" = [ drop nip call ] [ nip call ] if ; inline + [ [ alien-cell ] >>getter diff --git a/extra/colors/authors.txt b/basis/colors/authors.txt similarity index 100% rename from extra/colors/authors.txt rename to basis/colors/authors.txt diff --git a/extra/colors/colors.factor b/basis/colors/colors.factor similarity index 100% rename from extra/colors/colors.factor rename to basis/colors/colors.factor diff --git a/extra/colors/hsv/authors.txt b/basis/colors/hsv/authors.txt similarity index 100% rename from extra/colors/hsv/authors.txt rename to basis/colors/hsv/authors.txt diff --git a/extra/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor similarity index 100% rename from extra/colors/hsv/hsv.factor rename to basis/colors/hsv/hsv.factor diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 680103f188..77e4a53f7b 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -66,6 +66,10 @@ M: disjoint-set add-atom : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ; +GENERIC: disjoint-set-member? ( a disjoint-set -- ? ) + +M: disjoint-set disjoint-set-member? parents>> key? ; + GENERIC: equiv-set-size ( a disjoint-set -- n ) M: disjoint-set equiv-set-size [ representative ] keep count ; @@ -84,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- ) disjoint-set link-sets ] if ; +: equate-all-with ( seq a disjoint-set -- ) + '[ , , equate ] each ; + +: equate-all ( seq disjoint-set -- ) + over dup empty? [ 2drop ] [ + [ unclip-slice ] dip equate-all-with + ] if ; + M: disjoint-set clone [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ disjoint-set boa ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 9cbffe2d33..c4f4a46710 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -3,9 +3,9 @@ USING: accessors sequences parser kernel help help.markup help.topics words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors -combinators splitting debugger hashtables sorting effects vocabs -vocabs.loader assocs editors continuations classes.predicate -macros math sets eval ; +combinators combinators.short-circuit splitting debugger +hashtables sorting effects vocabs vocabs.loader assocs editors +continuations classes.predicate macros math sets eval ; IN: help.lint : check-example ( element -- ) @@ -43,15 +43,15 @@ IN: help.lint : check-values ( word element -- ) { - { [ over "declared-effect" word-prop ] [ 2drop ] } - { [ dup contains-funky-elements? not ] [ 2drop ] } - { [ over macro? not ] [ 2drop ] } + [ drop "declared-effect" word-prop not ] + [ nip contains-funky-elements? ] + [ drop macro? ] [ [ effect-values >array ] [ extract-values >array ] - bi* assert= + bi* = ] - } cond ; + } 2|| [ "$values don't match stack effect" throw ] unless ; : check-see-also ( word element -- ) nip \ $see-also swap elements [ diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 26b06dba8b..006e0e7881 100755 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors -destructors ; +destructors combinators ; IN: io.ports SYMBOL: default-buffer-size @@ -133,10 +133,12 @@ M: output-port stream-flush ( port -- ) M: output-port dispose* [ - [ handle>> &dispose drop ] - [ port-flush ] - [ handle>> shutdown ] - tri + { + [ handle>> &dispose drop ] + [ buffer>> &dispose drop ] + [ port-flush ] + [ handle>> shutdown ] + } cleave ] with-destructors ; M: buffered-port dispose* diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index c207eaa63c..118a8e8197 100755 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -1,5 +1,6 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: math IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline @@ -7,3 +8,5 @@ IN: math.constants : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline +: smallest-float ( -- x ) HEX: 1 bits>double ; foldable +: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index 714fc67c9f..f3c65e51a4 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -1,21 +1,27 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup arrays sequences ; IN: math.ranges ARTICLE: "ranges" "Ranges" - - "A " { $emphasis "range" } " is a virtual sequence with real elements " - "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "." - - $nl - - "Creating ranges:" - - { $subsection } - { $subsection [a,b] } - { $subsection (a,b] } - { $subsection [a,b) } - { $subsection (a,b) } - { $subsection [0,b] } - { $subsection [1,b] } - { $subsection [0,b) } ; \ No newline at end of file +"A " { $emphasis "range" } " is a virtual sequence with real number elements " +"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "." +$nl +"The class of ranges:" +{ $subsection range } +"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:" +{ $subsection [a,b] } +{ $subsection (a,b] } +{ $subsection [a,b) } +{ $subsection (a,b) } +{ $subsection [0,b] } +{ $subsection [1,b] } +{ $subsection [0,b) } +"Creating general ranges:" +{ $subsection } +"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example," +{ $code + "3 10 [a,b] [ sqrt ] map" +} +"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; + +ABOUT: "ranges" \ No newline at end of file diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 23a50700b3..168e118d4b 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -171,10 +171,11 @@ M: block section-fits? ( section -- ? ) line-limit? [ drop t ] [ call-next-method ] if ; : pprint-sections ( block advancer -- ) - swap sections>> [ line-break? not ] filter - unclip pprint-section [ - dup rot call pprint-section - ] with each ; inline + [ + sections>> [ line-break? not ] filter + unclip-slice pprint-section + ] dip + [ [ pprint-section ] bi ] curry each ; inline M: block short-section ( block -- ) [ advance ] pprint-sections ; diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index 5d350d80c4..7cc0e7efbb 100755 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -3,12 +3,6 @@ smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests -[ t ] [ - - dup clone "a" "b" set-header drop - headers>> assoc-empty? -] unit-test - { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail @@ -60,12 +54,13 @@ IN: smtp.tests "Ed " } >>to "Doug " >>from - prepare - dup headers>> >alist sort-keys [ - drop { "Date" "Message-Id" } member? not - ] assoc-filter - over to>> - rot from>> + [ + email>headers sort-keys [ + drop { "Date" "Message-Id" } member? not + ] assoc-filter + ] + [ to>> [ extract-email ] map ] + [ from>> extract-email ] tri ] unit-test [ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 16a13eafe8..63a37acf36 100755 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces io io.timeouts kernel logging io.sockets +USING: arrays namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar io.encodings.ascii -calendar.format accessors sets ; +math.parser random system calendar io.encodings.ascii summary +calendar.format accessors sets hashtables ; IN: smtp SYMBOL: smtp-domain @@ -23,6 +23,16 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) call ] with-client ; inline +TUPLE: email + { from string } + { to array } + { cc array } + { bcc array } + { subject string } + { body string } ; + +: ( -- email ) email new ; + : crlf ( -- ) "\r\n" write ; : command ( string -- ) write crlf flush ; @@ -30,10 +40,12 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : helo ( -- ) esmtp get "EHLO " "HELO " ? host-name append command ; +ERROR: bad-email-address email ; + : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. dup "\r\n>" intersect empty? - [ "Bad e-mail address: " prepend throw ] unless ; + [ bad-email-address ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" swap validate-address ">" 3append command ; @@ -44,8 +56,15 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : data ( -- ) "DATA" command ; +ERROR: message-contains-dot message ; + +M: message-contains-dot summary ( obj -- string ) + drop + "Message cannot contain . on a line by itself" ; + : validate-message ( msg -- msg' ) - "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; + "." over member? + [ message-contains-dot ] when ; : send-body ( body -- ) string-lines @@ -58,19 +77,37 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) LOG: smtp-response DEBUG +ERROR: smtp-error message ; +ERROR: smtp-server-busy < smtp-error ; +ERROR: smtp-syntax-error < smtp-error ; +ERROR: smtp-command-not-implemented < smtp-error ; +ERROR: smtp-bad-authentication < smtp-error ; +ERROR: smtp-mailbox-unavailable < smtp-error ; +ERROR: smtp-user-not-local < smtp-error ; +ERROR: smtp-exceeded-storage-allocation < smtp-error ; +ERROR: smtp-bad-mailbox-name < smtp-error ; +ERROR: smtp-transaction-failed < smtp-error ; + : check-response ( response -- ) + dup smtp-response { - { [ dup "220" head? ] [ smtp-response ] } - { [ dup "235" swap subseq? ] [ smtp-response ] } - { [ dup "250" head? ] [ smtp-response ] } - { [ dup "221" head? ] [ smtp-response ] } - { [ dup "bye" head? ] [ smtp-response ] } - { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "354" head? ] [ smtp-response ] } - { [ dup "50" head? ] [ smtp-response "syntax error" throw ] } - { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] } - { [ dup "55" head? ] [ smtp-response "fatal error" throw ] } - [ "unknown error" throw ] + { [ dup "bye" head? ] [ drop ] } + { [ dup "220" head? ] [ drop ] } + { [ dup "235" swap subseq? ] [ drop ] } + { [ dup "250" head? ] [ drop ] } + { [ dup "221" head? ] [ drop ] } + { [ dup "354" head? ] [ drop ] } + { [ dup "4" head? ] [ smtp-server-busy ] } + { [ dup "500" head? ] [ smtp-syntax-error ] } + { [ dup "501" head? ] [ smtp-command-not-implemented ] } + { [ dup "50" head? ] [ smtp-syntax-error ] } + { [ dup "53" head? ] [ smtp-bad-authentication ] } + { [ dup "550" head? ] [ smtp-mailbox-unavailable ] } + { [ dup "551" head? ] [ smtp-user-not-local ] } + { [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] } + { [ dup "553" head? ] [ smtp-bad-mailbox-name ] } + { [ dup "554" head? ] [ smtp-transaction-failed ] } + [ smtp-error ] } cond ; : multiline? ( response -- boolean ) @@ -89,41 +126,19 @@ LOG: smtp-response DEBUG : get-ok ( -- ) receive-response check-response ; +ERROR: invalid-header-string string ; + : validate-header ( string -- string' ) dup "\r\n" intersect empty? - [ "Invalid header string: " prepend throw ] unless ; + [ invalid-header-string ] unless ; : write-header ( key value -- ) - swap - validate-header write - ": " write - validate-header write - crlf ; + [ validate-header write ] + [ ": " write validate-header write ] bi* crlf ; : write-headers ( assoc -- ) [ write-header ] assoc-each ; -TUPLE: email from to subject headers body ; - -M: email clone - call-next-method [ clone ] change-headers ; - -: (send) ( email -- ) - [ - helo get-ok - dup from>> mail-from get-ok - dup to>> [ rcpt-to get-ok ] each - data get-ok - dup headers>> write-headers - crlf - body>> send-body get-ok - quit get-ok - ] with-smtp-connection ; - -: extract-email ( recepient -- email ) - #! This could be much smarter. - " " last-split1 swap or "<" ?head drop ">" ?tail drop ; - : message-id ( -- string ) [ "<" % @@ -135,25 +150,38 @@ M: email clone ">" % ] "" make ; -: set-header ( email value key -- email ) - pick headers>> set-at ; +: extract-email ( recepient -- email ) + #! This could be much smarter. + " " last-split1 swap or "<" ?head drop ">" ?tail drop ; -: prepare ( email -- email ) - clone - dup from>> "From" set-header - [ extract-email ] change-from - dup to>> ", " join "To" set-header - [ [ extract-email ] map ] change-to - dup subject>> "Subject" set-header - now timestamp>rfc822 "Date" set-header - message-id "Message-Id" set-header ; +: email>headers ( email -- hashtable ) + [ + { + [ from>> "From" set ] + [ to>> ", " join "To" set ] + [ cc>> ", " join [ "Cc" set ] unless-empty ] + [ subject>> "Subject" set ] + } cleave + now timestamp>rfc822 "Date" set + message-id "Message-Id" set + ] { } make-assoc ; -: ( -- email ) - email new - H{ } clone >>headers ; +: (send-email) ( headers email -- ) + [ + helo get-ok + dup from>> extract-email mail-from get-ok + dup to>> [ extract-email rcpt-to get-ok ] each + dup cc>> [ extract-email rcpt-to get-ok ] each + dup bcc>> [ extract-email rcpt-to get-ok ] each + data get-ok + swap write-headers + crlf + body>> send-body get-ok + quit get-ok + ] with-smtp-connection ; : send-email ( email -- ) - prepare (send) ; + [ email>headers ] keep (send-email) ; ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about ! CRAM MD5, and the old code didn't work properly either, so here diff --git a/extra/ui/authors.txt b/basis/ui/authors.txt similarity index 100% rename from extra/ui/authors.txt rename to basis/ui/authors.txt diff --git a/extra/ui/backend/authors.txt b/basis/ui/backend/authors.txt similarity index 100% rename from extra/ui/backend/authors.txt rename to basis/ui/backend/authors.txt diff --git a/extra/ui/backend/backend.factor b/basis/ui/backend/backend.factor similarity index 100% rename from extra/ui/backend/backend.factor rename to basis/ui/backend/backend.factor diff --git a/extra/ui/backend/summary.txt b/basis/ui/backend/summary.txt similarity index 100% rename from extra/ui/backend/summary.txt rename to basis/ui/backend/summary.txt diff --git a/extra/ui/clipboards/authors.txt b/basis/ui/clipboards/authors.txt similarity index 100% rename from extra/ui/clipboards/authors.txt rename to basis/ui/clipboards/authors.txt diff --git a/extra/ui/clipboards/clipboards-docs.factor b/basis/ui/clipboards/clipboards-docs.factor similarity index 100% rename from extra/ui/clipboards/clipboards-docs.factor rename to basis/ui/clipboards/clipboards-docs.factor diff --git a/extra/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor similarity index 100% rename from extra/ui/clipboards/clipboards.factor rename to basis/ui/clipboards/clipboards.factor diff --git a/extra/ui/clipboards/summary.txt b/basis/ui/clipboards/summary.txt similarity index 100% rename from extra/ui/clipboards/summary.txt rename to basis/ui/clipboards/summary.txt diff --git a/extra/ui/cocoa/authors.txt b/basis/ui/cocoa/authors.txt similarity index 100% rename from extra/ui/cocoa/authors.txt rename to basis/ui/cocoa/authors.txt diff --git a/extra/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor similarity index 100% rename from extra/ui/cocoa/cocoa.factor rename to basis/ui/cocoa/cocoa.factor diff --git a/extra/ui/cocoa/summary.txt b/basis/ui/cocoa/summary.txt similarity index 100% rename from extra/ui/cocoa/summary.txt rename to basis/ui/cocoa/summary.txt diff --git a/extra/ui/cocoa/tags.txt b/basis/ui/cocoa/tags.txt similarity index 100% rename from extra/ui/cocoa/tags.txt rename to basis/ui/cocoa/tags.txt diff --git a/extra/ui/cocoa/tools/authors.txt b/basis/ui/cocoa/tools/authors.txt similarity index 100% rename from extra/ui/cocoa/tools/authors.txt rename to basis/ui/cocoa/tools/authors.txt diff --git a/extra/ui/cocoa/tools/summary.txt b/basis/ui/cocoa/tools/summary.txt similarity index 100% rename from extra/ui/cocoa/tools/summary.txt rename to basis/ui/cocoa/tools/summary.txt diff --git a/extra/ui/cocoa/tools/tags.txt b/basis/ui/cocoa/tools/tags.txt similarity index 100% rename from extra/ui/cocoa/tools/tags.txt rename to basis/ui/cocoa/tools/tags.txt diff --git a/extra/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor similarity index 100% rename from extra/ui/cocoa/tools/tools.factor rename to basis/ui/cocoa/tools/tools.factor diff --git a/extra/ui/cocoa/views/authors.txt b/basis/ui/cocoa/views/authors.txt similarity index 100% rename from extra/ui/cocoa/views/authors.txt rename to basis/ui/cocoa/views/authors.txt diff --git a/extra/ui/cocoa/views/summary.txt b/basis/ui/cocoa/views/summary.txt similarity index 100% rename from extra/ui/cocoa/views/summary.txt rename to basis/ui/cocoa/views/summary.txt diff --git a/extra/ui/cocoa/views/tags.txt b/basis/ui/cocoa/views/tags.txt similarity index 100% rename from extra/ui/cocoa/views/tags.txt rename to basis/ui/cocoa/views/tags.txt diff --git a/extra/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor similarity index 100% rename from extra/ui/cocoa/views/views.factor rename to basis/ui/cocoa/views/views.factor diff --git a/extra/ui/commands/authors.txt b/basis/ui/commands/authors.txt similarity index 100% rename from extra/ui/commands/authors.txt rename to basis/ui/commands/authors.txt diff --git a/extra/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor similarity index 100% rename from extra/ui/commands/commands-docs.factor rename to basis/ui/commands/commands-docs.factor diff --git a/extra/ui/commands/commands-tests.factor b/basis/ui/commands/commands-tests.factor similarity index 100% rename from extra/ui/commands/commands-tests.factor rename to basis/ui/commands/commands-tests.factor diff --git a/extra/ui/commands/commands.factor b/basis/ui/commands/commands.factor similarity index 100% rename from extra/ui/commands/commands.factor rename to basis/ui/commands/commands.factor diff --git a/extra/ui/commands/summary.txt b/basis/ui/commands/summary.txt similarity index 100% rename from extra/ui/commands/summary.txt rename to basis/ui/commands/summary.txt diff --git a/extra/ui/freetype/authors.txt b/basis/ui/freetype/authors.txt similarity index 100% rename from extra/ui/freetype/authors.txt rename to basis/ui/freetype/authors.txt diff --git a/extra/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor similarity index 100% rename from extra/ui/freetype/freetype-docs.factor rename to basis/ui/freetype/freetype-docs.factor diff --git a/extra/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor similarity index 100% rename from extra/ui/freetype/freetype.factor rename to basis/ui/freetype/freetype.factor diff --git a/extra/ui/freetype/summary.txt b/basis/ui/freetype/summary.txt similarity index 100% rename from extra/ui/freetype/summary.txt rename to basis/ui/freetype/summary.txt diff --git a/extra/ui/gadgets/authors.txt b/basis/ui/gadgets/authors.txt similarity index 100% rename from extra/ui/gadgets/authors.txt rename to basis/ui/gadgets/authors.txt diff --git a/extra/ui/gadgets/books/authors.txt b/basis/ui/gadgets/books/authors.txt similarity index 100% rename from extra/ui/gadgets/books/authors.txt rename to basis/ui/gadgets/books/authors.txt diff --git a/extra/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor similarity index 100% rename from extra/ui/gadgets/books/books-docs.factor rename to basis/ui/gadgets/books/books-docs.factor diff --git a/extra/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor similarity index 100% rename from extra/ui/gadgets/books/books-tests.factor rename to basis/ui/gadgets/books/books-tests.factor diff --git a/extra/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor similarity index 100% rename from extra/ui/gadgets/books/books.factor rename to basis/ui/gadgets/books/books.factor diff --git a/extra/ui/gadgets/books/summary.txt b/basis/ui/gadgets/books/summary.txt similarity index 100% rename from extra/ui/gadgets/books/summary.txt rename to basis/ui/gadgets/books/summary.txt diff --git a/extra/ui/gadgets/borders/authors.txt b/basis/ui/gadgets/borders/authors.txt similarity index 100% rename from extra/ui/gadgets/borders/authors.txt rename to basis/ui/gadgets/borders/authors.txt diff --git a/extra/ui/gadgets/borders/borders-docs.factor b/basis/ui/gadgets/borders/borders-docs.factor similarity index 100% rename from extra/ui/gadgets/borders/borders-docs.factor rename to basis/ui/gadgets/borders/borders-docs.factor diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/basis/ui/gadgets/borders/borders-tests.factor similarity index 100% rename from extra/ui/gadgets/borders/borders-tests.factor rename to basis/ui/gadgets/borders/borders-tests.factor diff --git a/extra/ui/gadgets/borders/borders.factor b/basis/ui/gadgets/borders/borders.factor similarity index 100% rename from extra/ui/gadgets/borders/borders.factor rename to basis/ui/gadgets/borders/borders.factor diff --git a/extra/ui/gadgets/borders/summary.txt b/basis/ui/gadgets/borders/summary.txt similarity index 100% rename from extra/ui/gadgets/borders/summary.txt rename to basis/ui/gadgets/borders/summary.txt diff --git a/extra/ui/gadgets/buttons/authors.txt b/basis/ui/gadgets/buttons/authors.txt similarity index 100% rename from extra/ui/gadgets/buttons/authors.txt rename to basis/ui/gadgets/buttons/authors.txt diff --git a/extra/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor similarity index 100% rename from extra/ui/gadgets/buttons/buttons-docs.factor rename to basis/ui/gadgets/buttons/buttons-docs.factor diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor similarity index 100% rename from extra/ui/gadgets/buttons/buttons-tests.factor rename to basis/ui/gadgets/buttons/buttons-tests.factor diff --git a/extra/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor similarity index 98% rename from extra/ui/gadgets/buttons/buttons.factor rename to basis/ui/gadgets/buttons/buttons.factor index c5a5e8bad8..d60901d993 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -199,14 +199,11 @@ M: radio-control model-changed : ( value model label -- gadget ) label-on-right radio-button-theme ; -: radio-buttons-theme ( gadget -- ) - { 5 5 } >>gap drop ; - : ( model assoc -- gadget ) -rot [ ] - dup radio-buttons-theme ; + { 5 5 } >>gap ; : ( value model label -- gadget ) bevel-button-theme ; diff --git a/extra/ui/gadgets/buttons/summary.txt b/basis/ui/gadgets/buttons/summary.txt similarity index 100% rename from extra/ui/gadgets/buttons/summary.txt rename to basis/ui/gadgets/buttons/summary.txt diff --git a/extra/ui/gadgets/canvas/authors.txt b/basis/ui/gadgets/canvas/authors.txt similarity index 100% rename from extra/ui/gadgets/canvas/authors.txt rename to basis/ui/gadgets/canvas/authors.txt diff --git a/extra/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor similarity index 100% rename from extra/ui/gadgets/canvas/canvas.factor rename to basis/ui/gadgets/canvas/canvas.factor diff --git a/extra/ui/gadgets/cartesian/cartesian.factor b/basis/ui/gadgets/cartesian/cartesian.factor similarity index 100% rename from extra/ui/gadgets/cartesian/cartesian.factor rename to basis/ui/gadgets/cartesian/cartesian.factor diff --git a/extra/ui/gadgets/editors/authors.txt b/basis/ui/gadgets/editors/authors.txt similarity index 100% rename from extra/ui/gadgets/editors/authors.txt rename to basis/ui/gadgets/editors/authors.txt diff --git a/extra/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor similarity index 100% rename from extra/ui/gadgets/editors/editors-docs.factor rename to basis/ui/gadgets/editors/editors-docs.factor diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor similarity index 100% rename from extra/ui/gadgets/editors/editors-tests.factor rename to basis/ui/gadgets/editors/editors-tests.factor diff --git a/extra/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor similarity index 100% rename from extra/ui/gadgets/editors/editors.factor rename to basis/ui/gadgets/editors/editors.factor diff --git a/extra/ui/gadgets/editors/summary.txt b/basis/ui/gadgets/editors/summary.txt similarity index 100% rename from extra/ui/gadgets/editors/summary.txt rename to basis/ui/gadgets/editors/summary.txt diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/basis/ui/gadgets/frame-buffer/frame-buffer.factor similarity index 100% rename from extra/ui/gadgets/frame-buffer/frame-buffer.factor rename to basis/ui/gadgets/frame-buffer/frame-buffer.factor diff --git a/extra/ui/gadgets/frames/authors.txt b/basis/ui/gadgets/frames/authors.txt similarity index 100% rename from extra/ui/gadgets/frames/authors.txt rename to basis/ui/gadgets/frames/authors.txt diff --git a/extra/ui/gadgets/frames/frames-docs.factor b/basis/ui/gadgets/frames/frames-docs.factor similarity index 100% rename from extra/ui/gadgets/frames/frames-docs.factor rename to basis/ui/gadgets/frames/frames-docs.factor diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/basis/ui/gadgets/frames/frames-tests.factor similarity index 100% rename from extra/ui/gadgets/frames/frames-tests.factor rename to basis/ui/gadgets/frames/frames-tests.factor diff --git a/extra/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor similarity index 100% rename from extra/ui/gadgets/frames/frames.factor rename to basis/ui/gadgets/frames/frames.factor diff --git a/extra/ui/gadgets/frames/summary.txt b/basis/ui/gadgets/frames/summary.txt similarity index 100% rename from extra/ui/gadgets/frames/summary.txt rename to basis/ui/gadgets/frames/summary.txt diff --git a/extra/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor similarity index 100% rename from extra/ui/gadgets/gadgets-docs.factor rename to basis/ui/gadgets/gadgets-docs.factor diff --git a/extra/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor similarity index 100% rename from extra/ui/gadgets/gadgets-tests.factor rename to basis/ui/gadgets/gadgets-tests.factor diff --git a/extra/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor similarity index 100% rename from extra/ui/gadgets/gadgets.factor rename to basis/ui/gadgets/gadgets.factor diff --git a/extra/ui/gadgets/grid-lines/authors.txt b/basis/ui/gadgets/grid-lines/authors.txt similarity index 100% rename from extra/ui/gadgets/grid-lines/authors.txt rename to basis/ui/gadgets/grid-lines/authors.txt diff --git a/extra/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor similarity index 100% rename from extra/ui/gadgets/grid-lines/grid-lines-docs.factor rename to basis/ui/gadgets/grid-lines/grid-lines-docs.factor diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor similarity index 100% rename from extra/ui/gadgets/grid-lines/grid-lines.factor rename to basis/ui/gadgets/grid-lines/grid-lines.factor diff --git a/extra/ui/gadgets/grid-lines/summary.txt b/basis/ui/gadgets/grid-lines/summary.txt similarity index 100% rename from extra/ui/gadgets/grid-lines/summary.txt rename to basis/ui/gadgets/grid-lines/summary.txt diff --git a/extra/ui/gadgets/grids/authors.txt b/basis/ui/gadgets/grids/authors.txt similarity index 100% rename from extra/ui/gadgets/grids/authors.txt rename to basis/ui/gadgets/grids/authors.txt diff --git a/extra/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor similarity index 100% rename from extra/ui/gadgets/grids/grids-docs.factor rename to basis/ui/gadgets/grids/grids-docs.factor diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor similarity index 100% rename from extra/ui/gadgets/grids/grids-tests.factor rename to basis/ui/gadgets/grids/grids-tests.factor diff --git a/extra/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor similarity index 100% rename from extra/ui/gadgets/grids/grids.factor rename to basis/ui/gadgets/grids/grids.factor diff --git a/extra/ui/gadgets/grids/summary.txt b/basis/ui/gadgets/grids/summary.txt similarity index 100% rename from extra/ui/gadgets/grids/summary.txt rename to basis/ui/gadgets/grids/summary.txt diff --git a/extra/ui/gadgets/handler/authors.txt b/basis/ui/gadgets/handler/authors.txt similarity index 100% rename from extra/ui/gadgets/handler/authors.txt rename to basis/ui/gadgets/handler/authors.txt diff --git a/extra/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor similarity index 100% rename from extra/ui/gadgets/handler/handler.factor rename to basis/ui/gadgets/handler/handler.factor diff --git a/extra/ui/gadgets/incremental/authors.txt b/basis/ui/gadgets/incremental/authors.txt similarity index 100% rename from extra/ui/gadgets/incremental/authors.txt rename to basis/ui/gadgets/incremental/authors.txt diff --git a/extra/ui/gadgets/incremental/incremental-docs.factor b/basis/ui/gadgets/incremental/incremental-docs.factor similarity index 100% rename from extra/ui/gadgets/incremental/incremental-docs.factor rename to basis/ui/gadgets/incremental/incremental-docs.factor diff --git a/extra/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor similarity index 100% rename from extra/ui/gadgets/incremental/incremental.factor rename to basis/ui/gadgets/incremental/incremental.factor diff --git a/extra/ui/gadgets/incremental/summary.txt b/basis/ui/gadgets/incremental/summary.txt similarity index 100% rename from extra/ui/gadgets/incremental/summary.txt rename to basis/ui/gadgets/incremental/summary.txt diff --git a/extra/ui/gadgets/labelled/authors.txt b/basis/ui/gadgets/labelled/authors.txt similarity index 100% rename from extra/ui/gadgets/labelled/authors.txt rename to basis/ui/gadgets/labelled/authors.txt diff --git a/extra/ui/gadgets/labelled/labelled-docs.factor b/basis/ui/gadgets/labelled/labelled-docs.factor similarity index 100% rename from extra/ui/gadgets/labelled/labelled-docs.factor rename to basis/ui/gadgets/labelled/labelled-docs.factor diff --git a/extra/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor similarity index 100% rename from extra/ui/gadgets/labelled/labelled.factor rename to basis/ui/gadgets/labelled/labelled.factor diff --git a/extra/ui/gadgets/labelled/summary.txt b/basis/ui/gadgets/labelled/summary.txt similarity index 100% rename from extra/ui/gadgets/labelled/summary.txt rename to basis/ui/gadgets/labelled/summary.txt diff --git a/extra/ui/gadgets/labels/authors.txt b/basis/ui/gadgets/labels/authors.txt similarity index 100% rename from extra/ui/gadgets/labels/authors.txt rename to basis/ui/gadgets/labels/authors.txt diff --git a/extra/ui/gadgets/labels/labels-docs.factor b/basis/ui/gadgets/labels/labels-docs.factor similarity index 100% rename from extra/ui/gadgets/labels/labels-docs.factor rename to basis/ui/gadgets/labels/labels-docs.factor diff --git a/extra/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor similarity index 100% rename from extra/ui/gadgets/labels/labels.factor rename to basis/ui/gadgets/labels/labels.factor diff --git a/extra/ui/gadgets/labels/summary.txt b/basis/ui/gadgets/labels/summary.txt similarity index 100% rename from extra/ui/gadgets/labels/summary.txt rename to basis/ui/gadgets/labels/summary.txt diff --git a/extra/ui/gadgets/lib/authors.txt b/basis/ui/gadgets/lib/authors.txt similarity index 100% rename from extra/ui/gadgets/lib/authors.txt rename to basis/ui/gadgets/lib/authors.txt diff --git a/extra/ui/gadgets/lib/lib.factor b/basis/ui/gadgets/lib/lib.factor similarity index 100% rename from extra/ui/gadgets/lib/lib.factor rename to basis/ui/gadgets/lib/lib.factor diff --git a/extra/ui/gadgets/lists/authors.txt b/basis/ui/gadgets/lists/authors.txt similarity index 100% rename from extra/ui/gadgets/lists/authors.txt rename to basis/ui/gadgets/lists/authors.txt diff --git a/extra/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor similarity index 100% rename from extra/ui/gadgets/lists/lists-docs.factor rename to basis/ui/gadgets/lists/lists-docs.factor diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/basis/ui/gadgets/lists/lists-tests.factor similarity index 100% rename from extra/ui/gadgets/lists/lists-tests.factor rename to basis/ui/gadgets/lists/lists-tests.factor diff --git a/extra/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor similarity index 100% rename from extra/ui/gadgets/lists/lists.factor rename to basis/ui/gadgets/lists/lists.factor diff --git a/extra/ui/gadgets/lists/summary.txt b/basis/ui/gadgets/lists/summary.txt similarity index 100% rename from extra/ui/gadgets/lists/summary.txt rename to basis/ui/gadgets/lists/summary.txt diff --git a/extra/ui/gadgets/menus/authors.txt b/basis/ui/gadgets/menus/authors.txt similarity index 100% rename from extra/ui/gadgets/menus/authors.txt rename to basis/ui/gadgets/menus/authors.txt diff --git a/extra/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor similarity index 100% rename from extra/ui/gadgets/menus/menus-docs.factor rename to basis/ui/gadgets/menus/menus-docs.factor diff --git a/extra/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor similarity index 100% rename from extra/ui/gadgets/menus/menus.factor rename to basis/ui/gadgets/menus/menus.factor diff --git a/extra/ui/gadgets/menus/summary.txt b/basis/ui/gadgets/menus/summary.txt similarity index 100% rename from extra/ui/gadgets/menus/summary.txt rename to basis/ui/gadgets/menus/summary.txt diff --git a/extra/ui/gadgets/packs/authors.txt b/basis/ui/gadgets/packs/authors.txt similarity index 100% rename from extra/ui/gadgets/packs/authors.txt rename to basis/ui/gadgets/packs/authors.txt diff --git a/extra/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor similarity index 100% rename from extra/ui/gadgets/packs/packs-docs.factor rename to basis/ui/gadgets/packs/packs-docs.factor diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor similarity index 100% rename from extra/ui/gadgets/packs/packs-tests.factor rename to basis/ui/gadgets/packs/packs-tests.factor diff --git a/extra/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor similarity index 100% rename from extra/ui/gadgets/packs/packs.factor rename to basis/ui/gadgets/packs/packs.factor diff --git a/extra/ui/gadgets/packs/summary.txt b/basis/ui/gadgets/packs/summary.txt similarity index 100% rename from extra/ui/gadgets/packs/summary.txt rename to basis/ui/gadgets/packs/summary.txt diff --git a/extra/ui/gadgets/panes/authors.txt b/basis/ui/gadgets/panes/authors.txt similarity index 100% rename from extra/ui/gadgets/panes/authors.txt rename to basis/ui/gadgets/panes/authors.txt diff --git a/extra/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor similarity index 100% rename from extra/ui/gadgets/panes/panes-docs.factor rename to basis/ui/gadgets/panes/panes-docs.factor diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor similarity index 100% rename from extra/ui/gadgets/panes/panes-tests.factor rename to basis/ui/gadgets/panes/panes-tests.factor diff --git a/extra/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor similarity index 100% rename from extra/ui/gadgets/panes/panes.factor rename to basis/ui/gadgets/panes/panes.factor diff --git a/extra/ui/gadgets/panes/summary.txt b/basis/ui/gadgets/panes/summary.txt similarity index 100% rename from extra/ui/gadgets/panes/summary.txt rename to basis/ui/gadgets/panes/summary.txt diff --git a/extra/ui/gadgets/paragraphs/authors.txt b/basis/ui/gadgets/paragraphs/authors.txt similarity index 100% rename from extra/ui/gadgets/paragraphs/authors.txt rename to basis/ui/gadgets/paragraphs/authors.txt diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor similarity index 100% rename from extra/ui/gadgets/paragraphs/paragraphs.factor rename to basis/ui/gadgets/paragraphs/paragraphs.factor diff --git a/extra/ui/gadgets/paragraphs/summary.txt b/basis/ui/gadgets/paragraphs/summary.txt similarity index 100% rename from extra/ui/gadgets/paragraphs/summary.txt rename to basis/ui/gadgets/paragraphs/summary.txt diff --git a/extra/ui/gadgets/plot/plot.factor b/basis/ui/gadgets/plot/plot.factor similarity index 98% rename from extra/ui/gadgets/plot/plot.factor rename to basis/ui/gadgets/plot/plot.factor index cf48c5ab9d..52cd2faed7 100644 --- a/extra/ui/gadgets/plot/plot.factor +++ b/basis/ui/gadgets/plot/plot.factor @@ -28,7 +28,7 @@ TUPLE: function function color ; GENERIC: plot-function ( plot object -- plot ) -M: quotation plot-function ( plot quotation -- plot ) +M: callable plot-function ( plot quotation -- plot ) >r dup plot-range r> '[ dup @ 2array ] map line-strip ; M: function plot-function ( plot function -- plot ) diff --git a/extra/ui/gadgets/presentations/authors.txt b/basis/ui/gadgets/presentations/authors.txt similarity index 100% rename from extra/ui/gadgets/presentations/authors.txt rename to basis/ui/gadgets/presentations/authors.txt diff --git a/extra/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor similarity index 100% rename from extra/ui/gadgets/presentations/presentations-docs.factor rename to basis/ui/gadgets/presentations/presentations-docs.factor diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/basis/ui/gadgets/presentations/presentations-tests.factor similarity index 100% rename from extra/ui/gadgets/presentations/presentations-tests.factor rename to basis/ui/gadgets/presentations/presentations-tests.factor diff --git a/extra/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor similarity index 100% rename from extra/ui/gadgets/presentations/presentations.factor rename to basis/ui/gadgets/presentations/presentations.factor diff --git a/extra/ui/gadgets/presentations/summary.txt b/basis/ui/gadgets/presentations/summary.txt similarity index 100% rename from extra/ui/gadgets/presentations/summary.txt rename to basis/ui/gadgets/presentations/summary.txt diff --git a/extra/ui/gadgets/scrollers/authors.txt b/basis/ui/gadgets/scrollers/authors.txt similarity index 100% rename from extra/ui/gadgets/scrollers/authors.txt rename to basis/ui/gadgets/scrollers/authors.txt diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor similarity index 100% rename from extra/ui/gadgets/scrollers/scrollers-docs.factor rename to basis/ui/gadgets/scrollers/scrollers-docs.factor diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor similarity index 100% rename from extra/ui/gadgets/scrollers/scrollers-tests.factor rename to basis/ui/gadgets/scrollers/scrollers-tests.factor diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor similarity index 100% rename from extra/ui/gadgets/scrollers/scrollers.factor rename to basis/ui/gadgets/scrollers/scrollers.factor diff --git a/extra/ui/gadgets/scrollers/summary.txt b/basis/ui/gadgets/scrollers/summary.txt similarity index 100% rename from extra/ui/gadgets/scrollers/summary.txt rename to basis/ui/gadgets/scrollers/summary.txt diff --git a/extra/ui/gadgets/slate/authors.txt b/basis/ui/gadgets/slate/authors.txt similarity index 100% rename from extra/ui/gadgets/slate/authors.txt rename to basis/ui/gadgets/slate/authors.txt diff --git a/extra/ui/gadgets/slate/slate.factor b/basis/ui/gadgets/slate/slate.factor similarity index 100% rename from extra/ui/gadgets/slate/slate.factor rename to basis/ui/gadgets/slate/slate.factor diff --git a/extra/ui/gadgets/sliders/authors.txt b/basis/ui/gadgets/sliders/authors.txt similarity index 100% rename from extra/ui/gadgets/sliders/authors.txt rename to basis/ui/gadgets/sliders/authors.txt diff --git a/extra/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor similarity index 100% rename from extra/ui/gadgets/sliders/sliders-docs.factor rename to basis/ui/gadgets/sliders/sliders-docs.factor diff --git a/extra/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor similarity index 100% rename from extra/ui/gadgets/sliders/sliders.factor rename to basis/ui/gadgets/sliders/sliders.factor diff --git a/extra/ui/gadgets/sliders/summary.txt b/basis/ui/gadgets/sliders/summary.txt similarity index 100% rename from extra/ui/gadgets/sliders/summary.txt rename to basis/ui/gadgets/sliders/summary.txt diff --git a/extra/ui/gadgets/slots/authors.txt b/basis/ui/gadgets/slots/authors.txt similarity index 100% rename from extra/ui/gadgets/slots/authors.txt rename to basis/ui/gadgets/slots/authors.txt diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/basis/ui/gadgets/slots/slots-tests.factor similarity index 100% rename from extra/ui/gadgets/slots/slots-tests.factor rename to basis/ui/gadgets/slots/slots-tests.factor diff --git a/extra/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor similarity index 100% rename from extra/ui/gadgets/slots/slots.factor rename to basis/ui/gadgets/slots/slots.factor diff --git a/extra/ui/gadgets/slots/summary.txt b/basis/ui/gadgets/slots/summary.txt similarity index 100% rename from extra/ui/gadgets/slots/summary.txt rename to basis/ui/gadgets/slots/summary.txt diff --git a/extra/ui/gadgets/status-bar/authors.txt b/basis/ui/gadgets/status-bar/authors.txt similarity index 100% rename from extra/ui/gadgets/status-bar/authors.txt rename to basis/ui/gadgets/status-bar/authors.txt diff --git a/extra/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor similarity index 100% rename from extra/ui/gadgets/status-bar/status-bar-docs.factor rename to basis/ui/gadgets/status-bar/status-bar-docs.factor diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor similarity index 100% rename from extra/ui/gadgets/status-bar/status-bar.factor rename to basis/ui/gadgets/status-bar/status-bar.factor diff --git a/extra/ui/gadgets/status-bar/summary.txt b/basis/ui/gadgets/status-bar/summary.txt similarity index 100% rename from extra/ui/gadgets/status-bar/summary.txt rename to basis/ui/gadgets/status-bar/summary.txt diff --git a/extra/ui/gadgets/summary.txt b/basis/ui/gadgets/summary.txt similarity index 100% rename from extra/ui/gadgets/summary.txt rename to basis/ui/gadgets/summary.txt diff --git a/extra/ui/gadgets/tabs/authors.txt b/basis/ui/gadgets/tabs/authors.txt similarity index 100% rename from extra/ui/gadgets/tabs/authors.txt rename to basis/ui/gadgets/tabs/authors.txt diff --git a/extra/ui/gadgets/tabs/summary.txt b/basis/ui/gadgets/tabs/summary.txt similarity index 100% rename from extra/ui/gadgets/tabs/summary.txt rename to basis/ui/gadgets/tabs/summary.txt diff --git a/extra/ui/gadgets/tabs/tabs.factor b/basis/ui/gadgets/tabs/tabs.factor similarity index 91% rename from extra/ui/gadgets/tabs/tabs.factor rename to basis/ui/gadgets/tabs/tabs.factor index 12031e5911..50e2df2e9e 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/basis/ui/gadgets/tabs/tabs.factor @@ -48,8 +48,8 @@ DEFER: (del-page) : del-page ( name tabbed -- ) [ names>> index ] 2keep (del-page) ; -: ( assoc -- tabbed ) - tabbed new-frame +: new-tabbed ( assoc class -- tabbed ) + new-frame 0 >>model 1 >>fill >>toggler dup toggler>> @left grid-add @@ -59,3 +59,4 @@ DEFER: (del-page) bi dup redo-toggler ; +: ( assoc -- tabbed ) tabbed new-tabbed ; diff --git a/extra/ui/gadgets/theme/authors.txt b/basis/ui/gadgets/theme/authors.txt similarity index 100% rename from extra/ui/gadgets/theme/authors.txt rename to basis/ui/gadgets/theme/authors.txt diff --git a/extra/ui/gadgets/theme/summary.txt b/basis/ui/gadgets/theme/summary.txt similarity index 100% rename from extra/ui/gadgets/theme/summary.txt rename to basis/ui/gadgets/theme/summary.txt diff --git a/extra/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor similarity index 54% rename from extra/ui/gadgets/theme/theme.factor rename to basis/ui/gadgets/theme/theme.factor index 20f560e309..46fa0105a3 100644 --- a/extra/ui/gadgets/theme/theme.factor +++ b/basis/ui/gadgets/theme/theme.factor @@ -18,41 +18,41 @@ IN: ui.gadgets.theme : plain-gradient T{ gradient f { - T{ rgba f 0.94 0.94 0.94 1.0 } - T{ rgba f 0.83 0.83 0.83 1.0 } - T{ rgba f 0.83 0.83 0.83 1.0 } - T{ rgba f 0.62 0.62 0.62 1.0 } + T{ gray f 0.94 1.0 } + T{ gray f 0.83 1.0 } + T{ gray f 0.83 1.0 } + T{ gray f 0.62 1.0 } } } ; : rollover-gradient T{ gradient f { - T{ rgba f 1.0 1.0 1.0 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.75 0.75 0.75 1.0 } + T{ gray f 1.0 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.75 1.0 } } } ; : pressed-gradient T{ gradient f { - T{ rgba f 0.75 0.75 0.75 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 1.0 1.0 1.0 1.0 } + T{ gray f 0.75 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 1.0 1.0 } } } ; : selected-gradient T{ gradient f { - T{ rgba f 0.65 0.65 0.65 1.0 } - T{ rgba f 0.8 0.8 0.8 1.0 } - T{ rgba f 0.8 0.8 0.8 1.0 } - T{ rgba f 1.0 1.0 1.0 1.0 } + T{ gray f 0.65 1.0 } + T{ gray f 0.8 1.0 } + T{ gray f 0.8 1.0 } + T{ gray f 1.0 1.0 } } } ; : lowered-gradient T{ gradient f { - T{ rgba f 0.37 0.37 0.37 1.0 } - T{ rgba f 0.43 0.43 0.43 1.0 } - T{ rgba f 0.5 0.5 0.5 1.0 } + T{ gray f 0.37 1.0 } + T{ gray f 0.43 1.0 } + T{ gray f 0.5 1.0 } } } ; : sans-serif-font { "sans-serif" plain 12 } ; diff --git a/extra/ui/gadgets/tiling/tiling.factor b/basis/ui/gadgets/tiling/tiling.factor similarity index 100% rename from extra/ui/gadgets/tiling/tiling.factor rename to basis/ui/gadgets/tiling/tiling.factor diff --git a/extra/ui/gadgets/tracks/authors.txt b/basis/ui/gadgets/tracks/authors.txt similarity index 100% rename from extra/ui/gadgets/tracks/authors.txt rename to basis/ui/gadgets/tracks/authors.txt diff --git a/extra/ui/gadgets/tracks/summary.txt b/basis/ui/gadgets/tracks/summary.txt similarity index 100% rename from extra/ui/gadgets/tracks/summary.txt rename to basis/ui/gadgets/tracks/summary.txt diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor similarity index 100% rename from extra/ui/gadgets/tracks/tracks-docs.factor rename to basis/ui/gadgets/tracks/tracks-docs.factor diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/basis/ui/gadgets/tracks/tracks-tests.factor similarity index 100% rename from extra/ui/gadgets/tracks/tracks-tests.factor rename to basis/ui/gadgets/tracks/tracks-tests.factor diff --git a/extra/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor similarity index 100% rename from extra/ui/gadgets/tracks/tracks.factor rename to basis/ui/gadgets/tracks/tracks.factor diff --git a/extra/ui/gadgets/viewports/authors.txt b/basis/ui/gadgets/viewports/authors.txt similarity index 100% rename from extra/ui/gadgets/viewports/authors.txt rename to basis/ui/gadgets/viewports/authors.txt diff --git a/extra/ui/gadgets/viewports/summary.txt b/basis/ui/gadgets/viewports/summary.txt similarity index 100% rename from extra/ui/gadgets/viewports/summary.txt rename to basis/ui/gadgets/viewports/summary.txt diff --git a/extra/ui/gadgets/viewports/viewports-docs.factor b/basis/ui/gadgets/viewports/viewports-docs.factor similarity index 100% rename from extra/ui/gadgets/viewports/viewports-docs.factor rename to basis/ui/gadgets/viewports/viewports-docs.factor diff --git a/extra/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor similarity index 100% rename from extra/ui/gadgets/viewports/viewports.factor rename to basis/ui/gadgets/viewports/viewports.factor diff --git a/extra/ui/gadgets/worlds/authors.txt b/basis/ui/gadgets/worlds/authors.txt similarity index 100% rename from extra/ui/gadgets/worlds/authors.txt rename to basis/ui/gadgets/worlds/authors.txt diff --git a/extra/ui/gadgets/worlds/summary.txt b/basis/ui/gadgets/worlds/summary.txt similarity index 100% rename from extra/ui/gadgets/worlds/summary.txt rename to basis/ui/gadgets/worlds/summary.txt diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor similarity index 100% rename from extra/ui/gadgets/worlds/worlds-docs.factor rename to basis/ui/gadgets/worlds/worlds-docs.factor diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/basis/ui/gadgets/worlds/worlds-tests.factor similarity index 100% rename from extra/ui/gadgets/worlds/worlds-tests.factor rename to basis/ui/gadgets/worlds/worlds-tests.factor diff --git a/extra/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor similarity index 100% rename from extra/ui/gadgets/worlds/worlds.factor rename to basis/ui/gadgets/worlds/worlds.factor diff --git a/extra/ui/gadgets/wrappers/wrappers.factor b/basis/ui/gadgets/wrappers/wrappers.factor similarity index 100% rename from extra/ui/gadgets/wrappers/wrappers.factor rename to basis/ui/gadgets/wrappers/wrappers.factor diff --git a/extra/ui/gestures/authors.txt b/basis/ui/gestures/authors.txt similarity index 100% rename from extra/ui/gestures/authors.txt rename to basis/ui/gestures/authors.txt diff --git a/extra/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor similarity index 100% rename from extra/ui/gestures/gestures-docs.factor rename to basis/ui/gestures/gestures-docs.factor diff --git a/extra/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor similarity index 100% rename from extra/ui/gestures/gestures.factor rename to basis/ui/gestures/gestures.factor diff --git a/extra/ui/gestures/summary.txt b/basis/ui/gestures/summary.txt similarity index 100% rename from extra/ui/gestures/summary.txt rename to basis/ui/gestures/summary.txt diff --git a/extra/ui/operations/authors.txt b/basis/ui/operations/authors.txt similarity index 100% rename from extra/ui/operations/authors.txt rename to basis/ui/operations/authors.txt diff --git a/extra/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor similarity index 100% rename from extra/ui/operations/operations-docs.factor rename to basis/ui/operations/operations-docs.factor diff --git a/extra/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor similarity index 100% rename from extra/ui/operations/operations-tests.factor rename to basis/ui/operations/operations-tests.factor diff --git a/extra/ui/operations/operations.factor b/basis/ui/operations/operations.factor similarity index 100% rename from extra/ui/operations/operations.factor rename to basis/ui/operations/operations.factor diff --git a/extra/ui/operations/summary.txt b/basis/ui/operations/summary.txt similarity index 100% rename from extra/ui/operations/summary.txt rename to basis/ui/operations/summary.txt diff --git a/extra/ui/render/authors.txt b/basis/ui/render/authors.txt similarity index 100% rename from extra/ui/render/authors.txt rename to basis/ui/render/authors.txt diff --git a/extra/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor similarity index 100% rename from extra/ui/render/render-docs.factor rename to basis/ui/render/render-docs.factor diff --git a/extra/ui/render/render.factor b/basis/ui/render/render.factor similarity index 100% rename from extra/ui/render/render.factor rename to basis/ui/render/render.factor diff --git a/extra/ui/render/summary.txt b/basis/ui/render/summary.txt similarity index 100% rename from extra/ui/render/summary.txt rename to basis/ui/render/summary.txt diff --git a/extra/ui/summary.txt b/basis/ui/summary.txt similarity index 100% rename from extra/ui/summary.txt rename to basis/ui/summary.txt diff --git a/extra/ui/tools/authors.txt b/basis/ui/tools/authors.txt similarity index 100% rename from extra/ui/tools/authors.txt rename to basis/ui/tools/authors.txt diff --git a/extra/ui/tools/browser/authors.txt b/basis/ui/tools/browser/authors.txt similarity index 100% rename from extra/ui/tools/browser/authors.txt rename to basis/ui/tools/browser/authors.txt diff --git a/extra/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor similarity index 100% rename from extra/ui/tools/browser/browser-tests.factor rename to basis/ui/tools/browser/browser-tests.factor diff --git a/extra/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor similarity index 100% rename from extra/ui/tools/browser/browser.factor rename to basis/ui/tools/browser/browser.factor diff --git a/extra/ui/tools/browser/summary.txt b/basis/ui/tools/browser/summary.txt similarity index 100% rename from extra/ui/tools/browser/summary.txt rename to basis/ui/tools/browser/summary.txt diff --git a/extra/ui/tools/browser/tags.txt b/basis/ui/tools/browser/tags.txt similarity index 100% rename from extra/ui/tools/browser/tags.txt rename to basis/ui/tools/browser/tags.txt diff --git a/extra/ui/tools/debugger/authors.txt b/basis/ui/tools/debugger/authors.txt similarity index 100% rename from extra/ui/tools/debugger/authors.txt rename to basis/ui/tools/debugger/authors.txt diff --git a/extra/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor similarity index 100% rename from extra/ui/tools/debugger/debugger-docs.factor rename to basis/ui/tools/debugger/debugger-docs.factor diff --git a/extra/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor similarity index 100% rename from extra/ui/tools/debugger/debugger.factor rename to basis/ui/tools/debugger/debugger.factor diff --git a/extra/ui/tools/debugger/summary.txt b/basis/ui/tools/debugger/summary.txt similarity index 100% rename from extra/ui/tools/debugger/summary.txt rename to basis/ui/tools/debugger/summary.txt diff --git a/extra/ui/tools/debugger/tags.txt b/basis/ui/tools/debugger/tags.txt similarity index 100% rename from extra/ui/tools/debugger/tags.txt rename to basis/ui/tools/debugger/tags.txt diff --git a/extra/ui/tools/deploy/authors.txt b/basis/ui/tools/deploy/authors.txt similarity index 100% rename from extra/ui/tools/deploy/authors.txt rename to basis/ui/tools/deploy/authors.txt diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/basis/ui/tools/deploy/deploy-docs.factor similarity index 100% rename from extra/ui/tools/deploy/deploy-docs.factor rename to basis/ui/tools/deploy/deploy-docs.factor diff --git a/extra/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor similarity index 100% rename from extra/ui/tools/deploy/deploy.factor rename to basis/ui/tools/deploy/deploy.factor diff --git a/extra/ui/tools/inspector/authors.txt b/basis/ui/tools/inspector/authors.txt similarity index 100% rename from extra/ui/tools/inspector/authors.txt rename to basis/ui/tools/inspector/authors.txt diff --git a/extra/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor similarity index 100% rename from extra/ui/tools/inspector/inspector.factor rename to basis/ui/tools/inspector/inspector.factor diff --git a/extra/ui/tools/inspector/summary.txt b/basis/ui/tools/inspector/summary.txt similarity index 100% rename from extra/ui/tools/inspector/summary.txt rename to basis/ui/tools/inspector/summary.txt diff --git a/extra/ui/tools/inspector/tags.txt b/basis/ui/tools/inspector/tags.txt similarity index 100% rename from extra/ui/tools/inspector/tags.txt rename to basis/ui/tools/inspector/tags.txt diff --git a/extra/ui/tools/interactor/authors.txt b/basis/ui/tools/interactor/authors.txt similarity index 100% rename from extra/ui/tools/interactor/authors.txt rename to basis/ui/tools/interactor/authors.txt diff --git a/extra/ui/tools/interactor/interactor-docs.factor b/basis/ui/tools/interactor/interactor-docs.factor similarity index 100% rename from extra/ui/tools/interactor/interactor-docs.factor rename to basis/ui/tools/interactor/interactor-docs.factor diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor similarity index 100% rename from extra/ui/tools/interactor/interactor-tests.factor rename to basis/ui/tools/interactor/interactor-tests.factor diff --git a/extra/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor similarity index 100% rename from extra/ui/tools/interactor/interactor.factor rename to basis/ui/tools/interactor/interactor.factor diff --git a/extra/ui/tools/interactor/summary.txt b/basis/ui/tools/interactor/summary.txt similarity index 100% rename from extra/ui/tools/interactor/summary.txt rename to basis/ui/tools/interactor/summary.txt diff --git a/extra/ui/tools/listener/authors.txt b/basis/ui/tools/listener/authors.txt similarity index 100% rename from extra/ui/tools/listener/authors.txt rename to basis/ui/tools/listener/authors.txt diff --git a/extra/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor similarity index 100% rename from extra/ui/tools/listener/listener-tests.factor rename to basis/ui/tools/listener/listener-tests.factor diff --git a/extra/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor similarity index 100% rename from extra/ui/tools/listener/listener.factor rename to basis/ui/tools/listener/listener.factor diff --git a/extra/ui/tools/listener/summary.txt b/basis/ui/tools/listener/summary.txt similarity index 100% rename from extra/ui/tools/listener/summary.txt rename to basis/ui/tools/listener/summary.txt diff --git a/extra/ui/tools/listener/tags.txt b/basis/ui/tools/listener/tags.txt similarity index 100% rename from extra/ui/tools/listener/tags.txt rename to basis/ui/tools/listener/tags.txt diff --git a/extra/ui/tools/operations/authors.txt b/basis/ui/tools/operations/authors.txt similarity index 100% rename from extra/ui/tools/operations/authors.txt rename to basis/ui/tools/operations/authors.txt diff --git a/extra/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor similarity index 100% rename from extra/ui/tools/operations/operations.factor rename to basis/ui/tools/operations/operations.factor diff --git a/extra/ui/tools/operations/summary.txt b/basis/ui/tools/operations/summary.txt similarity index 100% rename from extra/ui/tools/operations/summary.txt rename to basis/ui/tools/operations/summary.txt diff --git a/extra/ui/tools/profiler/authors.txt b/basis/ui/tools/profiler/authors.txt similarity index 100% rename from extra/ui/tools/profiler/authors.txt rename to basis/ui/tools/profiler/authors.txt diff --git a/extra/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor similarity index 100% rename from extra/ui/tools/profiler/profiler.factor rename to basis/ui/tools/profiler/profiler.factor diff --git a/extra/ui/tools/profiler/summary.txt b/basis/ui/tools/profiler/summary.txt similarity index 100% rename from extra/ui/tools/profiler/summary.txt rename to basis/ui/tools/profiler/summary.txt diff --git a/extra/ui/tools/profiler/tags.txt b/basis/ui/tools/profiler/tags.txt similarity index 100% rename from extra/ui/tools/profiler/tags.txt rename to basis/ui/tools/profiler/tags.txt diff --git a/extra/ui/tools/search/authors.txt b/basis/ui/tools/search/authors.txt similarity index 100% rename from extra/ui/tools/search/authors.txt rename to basis/ui/tools/search/authors.txt diff --git a/extra/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor similarity index 100% rename from extra/ui/tools/search/search-tests.factor rename to basis/ui/tools/search/search-tests.factor diff --git a/extra/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor similarity index 100% rename from extra/ui/tools/search/search.factor rename to basis/ui/tools/search/search.factor diff --git a/extra/ui/tools/search/summary.txt b/basis/ui/tools/search/summary.txt similarity index 100% rename from extra/ui/tools/search/summary.txt rename to basis/ui/tools/search/summary.txt diff --git a/extra/ui/tools/summary.txt b/basis/ui/tools/summary.txt similarity index 100% rename from extra/ui/tools/summary.txt rename to basis/ui/tools/summary.txt diff --git a/extra/ui/tools/tags.txt b/basis/ui/tools/tags.txt similarity index 100% rename from extra/ui/tools/tags.txt rename to basis/ui/tools/tags.txt diff --git a/extra/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor similarity index 100% rename from extra/ui/tools/tools-docs.factor rename to basis/ui/tools/tools-docs.factor diff --git a/extra/ui/tools/tools-tests.factor b/basis/ui/tools/tools-tests.factor similarity index 100% rename from extra/ui/tools/tools-tests.factor rename to basis/ui/tools/tools-tests.factor diff --git a/extra/ui/tools/tools.factor b/basis/ui/tools/tools.factor similarity index 100% rename from extra/ui/tools/tools.factor rename to basis/ui/tools/tools.factor diff --git a/extra/ui/tools/traceback/authors.txt b/basis/ui/tools/traceback/authors.txt similarity index 100% rename from extra/ui/tools/traceback/authors.txt rename to basis/ui/tools/traceback/authors.txt diff --git a/extra/ui/tools/traceback/summary.txt b/basis/ui/tools/traceback/summary.txt similarity index 100% rename from extra/ui/tools/traceback/summary.txt rename to basis/ui/tools/traceback/summary.txt diff --git a/extra/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor similarity index 100% rename from extra/ui/tools/traceback/traceback.factor rename to basis/ui/tools/traceback/traceback.factor diff --git a/extra/ui/tools/walker/authors.txt b/basis/ui/tools/walker/authors.txt similarity index 100% rename from extra/ui/tools/walker/authors.txt rename to basis/ui/tools/walker/authors.txt diff --git a/extra/ui/tools/walker/summary.txt b/basis/ui/tools/walker/summary.txt similarity index 100% rename from extra/ui/tools/walker/summary.txt rename to basis/ui/tools/walker/summary.txt diff --git a/extra/ui/tools/walker/tags.txt b/basis/ui/tools/walker/tags.txt similarity index 100% rename from extra/ui/tools/walker/tags.txt rename to basis/ui/tools/walker/tags.txt diff --git a/extra/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor similarity index 100% rename from extra/ui/tools/walker/walker-docs.factor rename to basis/ui/tools/walker/walker-docs.factor diff --git a/extra/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor similarity index 100% rename from extra/ui/tools/walker/walker-tests.factor rename to basis/ui/tools/walker/walker-tests.factor diff --git a/extra/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor similarity index 100% rename from extra/ui/tools/walker/walker.factor rename to basis/ui/tools/walker/walker.factor diff --git a/extra/ui/tools/workspace/authors.txt b/basis/ui/tools/workspace/authors.txt similarity index 100% rename from extra/ui/tools/workspace/authors.txt rename to basis/ui/tools/workspace/authors.txt diff --git a/extra/ui/tools/workspace/summary.txt b/basis/ui/tools/workspace/summary.txt similarity index 100% rename from extra/ui/tools/workspace/summary.txt rename to basis/ui/tools/workspace/summary.txt diff --git a/extra/ui/tools/workspace/tags.txt b/basis/ui/tools/workspace/tags.txt similarity index 100% rename from extra/ui/tools/workspace/tags.txt rename to basis/ui/tools/workspace/tags.txt diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/basis/ui/tools/workspace/workspace-tests.factor similarity index 100% rename from extra/ui/tools/workspace/workspace-tests.factor rename to basis/ui/tools/workspace/workspace-tests.factor diff --git a/extra/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor similarity index 100% rename from extra/ui/tools/workspace/workspace.factor rename to basis/ui/tools/workspace/workspace.factor diff --git a/extra/ui/traverse/authors.txt b/basis/ui/traverse/authors.txt similarity index 100% rename from extra/ui/traverse/authors.txt rename to basis/ui/traverse/authors.txt diff --git a/extra/ui/traverse/summary.txt b/basis/ui/traverse/summary.txt similarity index 100% rename from extra/ui/traverse/summary.txt rename to basis/ui/traverse/summary.txt diff --git a/extra/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor similarity index 100% rename from extra/ui/traverse/traverse-tests.factor rename to basis/ui/traverse/traverse-tests.factor diff --git a/extra/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor similarity index 100% rename from extra/ui/traverse/traverse.factor rename to basis/ui/traverse/traverse.factor diff --git a/extra/ui/ui-docs.factor b/basis/ui/ui-docs.factor similarity index 100% rename from extra/ui/ui-docs.factor rename to basis/ui/ui-docs.factor diff --git a/extra/ui/ui.factor b/basis/ui/ui.factor similarity index 100% rename from extra/ui/ui.factor rename to basis/ui/ui.factor diff --git a/extra/ui/windows/authors.txt b/basis/ui/windows/authors.txt similarity index 100% rename from extra/ui/windows/authors.txt rename to basis/ui/windows/authors.txt diff --git a/extra/ui/windows/tags.txt b/basis/ui/windows/tags.txt similarity index 100% rename from extra/ui/windows/tags.txt rename to basis/ui/windows/tags.txt diff --git a/extra/ui/windows/windows.factor b/basis/ui/windows/windows.factor similarity index 100% rename from extra/ui/windows/windows.factor rename to basis/ui/windows/windows.factor diff --git a/extra/ui/x11/authors.txt b/basis/ui/x11/authors.txt similarity index 100% rename from extra/ui/x11/authors.txt rename to basis/ui/x11/authors.txt diff --git a/extra/ui/x11/tags.txt b/basis/ui/x11/tags.txt similarity index 100% rename from extra/ui/x11/tags.txt rename to basis/ui/x11/tags.txt diff --git a/extra/ui/x11/x11.factor b/basis/ui/x11/x11.factor similarity index 100% rename from extra/ui/x11/x11.factor rename to basis/ui/x11/x11.factor diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 0c669d2258..6934d5b8dc 100755 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -7,13 +7,16 @@ IN: unix : MAXPATHLEN 1024 ; inline -: O_RDONLY HEX: 0000 ; inline -: O_WRONLY HEX: 0001 ; inline -: O_RDWR HEX: 0002 ; inline -: O_APPEND HEX: 0008 ; inline -: O_CREAT HEX: 0200 ; inline -: O_TRUNC HEX: 0400 ; inline -: O_EXCL HEX: 0800 ; inline +: O_RDONLY HEX: 0000 ; inline +: O_WRONLY HEX: 0001 ; inline +: O_RDWR HEX: 0002 ; inline +: O_NONBLOCK HEX: 0004 ; inline +: O_APPEND HEX: 0008 ; inline +: O_CREAT HEX: 0200 ; inline +: O_TRUNC HEX: 0400 ; inline +: O_EXCL HEX: 0800 ; inline +: O_NOCTTY HEX: 20000 ; inline +: O_NDELAY O_NONBLOCK ; inline : SOL_SOCKET HEX: ffff ; inline : SO_REUSEADDR HEX: 4 ; inline @@ -24,7 +27,6 @@ IN: unix : F_SETFD 2 ; inline : F_SETFL 4 ; inline : FD_CLOEXEC 1 ; inline -: O_NONBLOCK 4 ; inline C-STRUCT: sockaddr-in { "uchar" "len" } diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 0efacee294..0c08cf0f2b 100755 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -7,13 +7,16 @@ USING: alien.syntax ; : MAXPATHLEN 1024 ; inline -: O_RDONLY HEX: 0000 ; inline -: O_WRONLY HEX: 0001 ; inline -: O_RDWR HEX: 0002 ; inline -: O_CREAT HEX: 0040 ; inline -: O_EXCL HEX: 0080 ; inline -: O_TRUNC HEX: 0200 ; inline -: O_APPEND HEX: 0400 ; inline +: O_RDONLY HEX: 0000 ; inline +: O_WRONLY HEX: 0001 ; inline +: O_RDWR HEX: 0002 ; inline +: O_CREAT HEX: 0040 ; inline +: O_EXCL HEX: 0080 ; inline +: O_NOCTTY HEX: 0100 ; inline +: O_TRUNC HEX: 0200 ; inline +: O_APPEND HEX: 0400 ; inline +: O_NONBLOCK HEX: 0800 ; inline +: O_NDELAY O_NONBLOCK ; inline : SOL_SOCKET 1 ; inline @@ -28,7 +31,6 @@ USING: alien.syntax ; : FD_CLOEXEC 1 ; inline : F_SETFL 4 ; inline -: O_NONBLOCK HEX: 800 ; inline C-STRUCT: addrinfo { "int" "flags" } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 083700493d..4ae74f8267 100755 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -192,4 +192,3 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { [ os bsd? ] [ "unix.bsd" require ] } { [ os solaris? ] [ "unix.solaris" require ] } } cond - diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index dc83a15e9b..2c584b7378 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -697,3 +697,7 @@ DEFER: error-y "forget-subclass-test" parse-stream drop ] unit-test + +[ ] [ + "IN: sequences TUPLE: reversed { seq read-only } ;" eval +] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 42b5826e95..94d3a64c45 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -104,8 +104,7 @@ ERROR: bad-superclass class ; [ tuple-instance? ] 2curry define-predicate ; : superclass-size ( class -- n ) - superclasses but-last-slice - [ "slots" word-prop length ] sigma ; + superclasses but-last [ "slots" word-prop length ] sigma ; : (instance-check-quot) ( class -- quot ) [ @@ -203,11 +202,11 @@ ERROR: bad-superclass class ; M: tuple-class update-class { + [ define-boa-check ] [ define-tuple-layout ] [ define-tuple-slots ] [ define-tuple-predicate ] [ define-tuple-prototype ] - [ define-boa-check ] } cleave ; : define-new-tuple-class ( class superclass slots -- ) @@ -280,11 +279,8 @@ M: tuple-class reset-class ] with each ] [ [ call-next-method ] - [ - { - "layout" "slots" "boa-check" "prototype" - } reset-props - ] bi + [ { "layout" "slots" "boa-check" "prototype" } reset-props ] + bi ] bi ; M: tuple-class rank-class drop 0 ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 188dcb3d11..d0c83d0ca2 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -117,10 +117,10 @@ ERROR: no-case ; ] [ drop f ] if ; : dispatch-case ( value from to default array -- ) - >r >r 3dup between? [ - drop - >fixnum r> drop r> dispatch + >r >r 3dup between? r> r> rot [ + >r 2drop - >fixnum r> dispatch ] [ - 2drop r> call r> drop + drop 2nip call ] if ; inline : dispatch-case-quot ( default assoc -- quot ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index c221ad073b..2e0aa4c279 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces sequences strings words assocs -combinators accessors arrays ; +USING: kernel math math.parser namespaces sequences strings +words assocs combinators accessors arrays ; IN: effects TUPLE: effect in out terminated? ; @@ -25,10 +25,11 @@ TUPLE: effect in out terminated? ; GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: word effect>string name>> ; -M: integer effect>string drop "object" ; +M: integer effect>string number>string ; M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; : stack-picture ( seq -- string ) + dup integer? [ "object" ] when [ [ effect>string % CHAR: \s , ] each ] "" make ; M: effect effect>string ( effect -- string ) diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index f60ee6d0d1..6a5e8d1bb0 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -34,10 +34,10 @@ GENERIC: engine>quot ( engine -- quot ) [ [ nip class<= ] curry assoc-filter ] 2bi ; : convert-methods ( assoc class word -- assoc' ) - over >r >r split-methods dup assoc-empty? [ - r> r> 3drop + over [ split-methods ] 2dip pick assoc-empty? [ + 3drop ] [ - r> execute r> pick set-at + [ execute ] dip pick set-at ] if ; inline : (picker) ( n -- quot ) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 3df441ae03..15ee233dbc 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -61,8 +61,8 @@ M: decoder stream-read1 : (read) ( n quot -- n string ) over 0 [ [ - >r call dup - [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + slip over + [ swapd set-nth-unsafe f ] [ 3drop t ] if ] 2curry find-integer ] keep ; inline diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index ae8a455c71..8030d6265e 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -24,7 +24,7 @@ SINGLETON: utf8 : triple ( stream byte -- stream char ) BIN: 1111 bitand append-nums append-nums ; inline -: quad ( stream byte -- stream char ) +: quadruple ( stream byte -- stream char ) BIN: 111 bitand append-nums append-nums append-nums ; inline : begin-utf8 ( stream byte -- stream char ) @@ -32,7 +32,7 @@ SINGLETON: utf8 { [ dup -7 shift zero? ] [ ] } { [ dup -5 shift BIN: 110 number= ] [ double ] } { [ dup -4 shift BIN: 1110 number= ] [ triple ] } - { [ dup -3 shift BIN: 11110 number= ] [ quad ] } + { [ dup -3 shift BIN: 11110 number= ] [ quadruple ] } [ drop replacement-char ] } cond ; inline diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0a1a3cb7f2..94f0ddea51 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -629,7 +629,7 @@ HELP: 2bi* "The following two lines are equivalent:" { $code "[ p ] [ q ] 2bi*" - ">r >r q r> r> q" + ">r >r p r> r> q" } } ; diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 1cb2ae6cdf..78705266ee 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -96,8 +96,8 @@ PRIVATE> : integer, ( num radix -- ) dup 1 <= [ "Invalid radix" throw ] when - dup >r /mod >digit , dup 0 > - [ r> integer, ] [ r> 2drop ] if ; + [ /mod >digit , ] keep over 0 > + [ integer, ] [ 2drop ] if ; PRIVATE> diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index c3126abf0d..ef67d23aaa 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -33,7 +33,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : first ( seq -- first ) 0 swap nth ; inline : second ( seq -- second ) 1 swap nth ; inline : third ( seq -- third ) 2 swap nth ; inline -: fourth ( seq -- fourth ) 3 swap nth ; inline +: fourth ( seq -- fourth ) 3 swap nth ; inline : set-first ( first seq -- ) 0 swap set-nth ; inline : set-second ( second seq -- ) 1 swap set-nth ; inline @@ -173,8 +173,6 @@ M: reversed length seq>> length ; INSTANCE: reversed virtual-sequence -: reverse ( seq -- newseq ) [ ] [ like ] bi ; - ! A slice of another sequence. TUPLE: slice { from read-only } @@ -336,11 +334,10 @@ M: immutable-sequence clone-like like ; pick >r >r (each) r> call r> finish-find ; inline : (find-from) ( n seq quot quot' -- i elt ) - >r >r 2dup bounds-check? [ - r> r> (find) - ] [ - r> r> 2drop 2drop f f - ] if ; inline + [ 2dup bounds-check? ] 2dip + [ (find) ] 2curry + [ 2drop f f ] + if ; inline : (monotonic) ( seq quot -- ? ) [ 2dup nth-unsafe rot 1+ rot nth-unsafe ] @@ -601,6 +598,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; tuck - 1- rot exchange-unsafe ] each 2drop ; +: reverse ( seq -- newseq ) + [ + dup [ length ] keep new-sequence + [ 0 swap copy ] keep + [ reverse-here ] keep + ] keep like ; + : sum-lengths ( seq -- n ) 0 [ length + ] reduce ; @@ -624,8 +628,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; ] keep like ; : padding ( seq n elt quot -- newseq ) - >r >r over length [-] dup zero? - [ r> r> 3drop ] [ r> r> call ] if ; inline + [ + [ over length [-] dup zero? [ drop ] ] dip + [ ] curry + ] dip compose if ; inline : pad-left ( seq n elt -- padded ) [ swap dup (append) ] padding ; @@ -730,9 +736,11 @@ PRIVATE> [ left-trim ] [ right-trim ] bi ; inline : sum ( seq -- n ) 0 [ + ] binary-reduce ; + : product ( seq -- n ) 1 [ * ] binary-reduce ; : infimum ( seq -- n ) dup first [ min ] reduce ; + : supremum ( seq -- n ) dup first [ max ] reduce ; : flip ( matrix -- newmatrix ) @@ -744,4 +752,3 @@ PRIVATE> : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline - diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index b7bb71f602..a7946f6740 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -25,19 +25,19 @@ TUPLE: merge : dump ( from to seq accum -- ) #! Optimize common case where to - from = 1, 2, or 3. - >r >r 2dup swap - dup 1 = - [ 2drop r> nth-unsafe r> push ] [ - dup 2 = [ - 2drop dup 1+ + >r >r 2dup swap - r> r> pick 1 = + [ >r >r 2drop r> nth-unsafe r> push ] [ + pick 2 = [ + >r >r 2drop dup 1+ r> [ nth-unsafe ] curry bi@ r> [ push ] curry bi@ ] [ - dup 3 = [ - 2drop dup 1+ dup 1+ + pick 3 = [ + >r >r 2drop dup 1+ dup 1+ r> [ nth-unsafe ] curry tri@ r> [ push ] curry tri@ ] [ - drop r> subseq r> push-all + >r nip subseq r> push-all ] if ] if ] if ; inline @@ -120,11 +120,13 @@ TUPLE: merge [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline : (sort-pairs) ( i1 i2 seq quot accum -- ) - >r >r 2dup length = [ - nip nth r> drop r> push + [ 2dup length = ] 2dip rot [ + [ drop nip nth ] dip push ] [ - tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq? - [ swap ] when r> tuck [ push ] 2bi@ + [ + [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq? + [ swap ] when + ] dip tuck [ push ] 2bi@ ] if ; inline : sort-pairs ( merge quot -- ) diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor index 12a558b2d2..cd82f335d8 100644 --- a/extra/24-game/24-game-docs.factor +++ b/extra/24-game/24-game-docs.factor @@ -31,12 +31,12 @@ HELP: 24-able ( -- vector ) "just using the provided commands and the 4 numbers. The Following are the " "provided commands: " { $link + } ", " { $link - } ", " { $link * } ", " - { $link / } ", and " { $link swap } "." + { $link / } ", " { $link swap } ", and " { $link rot } "." } { $examples { $example "USE: 24-game" - "24-able vector-24-able?" + "24-able vector-24-able? ." "t" } { $notes { $link 24-able? } " is used in " { $link 24-able } "." } diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 569cef8302..126215ab13 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -3,36 +3,61 @@ USING: kernel random namespaces shuffle sequences parser io math prettyprint combinators continuations -vectors words quotations accessors math.parser -backtrack math.ranges locals fry memoize macros assocs ; +arrays words quotations accessors math.parser backtrack assocs ; IN: 24-game - +SYMBOL: commands : nop ; : do-something ( a b -- c ) { + - * } amb-execute ; : maybe-swap ( a b -- a b ) { nop swap } amb-execute ; : some-rots ( a b c -- a b c ) #! Try each permutation of 3 elements. { nop rot -rot swap spin swapd } amb-execute ; -: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ; -: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ; +: makes-24? ( a b c d -- ? ) + [ + 2 [ some-rots do-something ] times + maybe-swap do-something + 24 = + ] + [ 4drop ] + if-amb ; : q ( -- obj ) "quit" ; -: show-commands ( -- ) "Commands: " write "commands" get unparse print ; +: show-commands ( -- ) "Commands: " write commands get unparse print ; : report ( vector -- ) unparse print show-commands ; : give-help ( -- ) "Command not found..." print show-commands ; : find-word ( string choices -- word ) [ name>> = ] with find nip ; -: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ; +: obtain-word ( -- word ) + readln commands get find-word dup + [ drop give-help obtain-word ] unless ; : done? ( vector -- t/f ) 1 swap length = ; -: victory? ( vector -- t/f ) V{ 24 } = ; -: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ; -: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ; +: victory? ( vector -- t/f ) { 24 } = ; +: apply-word ( vector word -- array ) 1quotation with-datastack >array ; +: update-commands ( vector -- ) + length 3 < + [ commands [ \ rot swap remove ] change ] + [ ] + if ; DEFER: check-status : quit-game ( vector -- ) drop "you're a quitter" print ; : quit? ( vector -- t/f ) peek "quit" = ; -: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ; -: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status ; -: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ; -: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ; -: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ; -: set-commands ( -- ) { + - * / rot swap q } "commands" set ; -: play-game ( -- ) set-commands 24-able repeat ; \ No newline at end of file +: end-game ( vector -- ) + dup victory? + [ drop "You WON!" ] + [ pop number>string " is not 24... You lose." append ] + if print ; + +! The following two words are mutually recursive, +! providing the repl loop of the game +: repeat ( vector -- ) + dup report obtain-word apply-word dup update-commands check-status ; +: check-status ( object -- ) + dup done? + [ end-game ] + [ dup quit? [ quit-game ] [ repeat ] if ] + if ; +: build-quad ( -- array ) 4 [ 10 random ] replicate >array ; +: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ; +: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; +: set-commands ( -- ) { + - * / rot swap q } commands set ; +: play-game ( -- ) set-commands 24-able repeat ; +MAIN: play-game \ No newline at end of file diff --git a/extra/24-game/tags.txt b/extra/24-game/tags.txt index cb5fc203e1..d2f0464fdb 100644 --- a/extra/24-game/tags.txt +++ b/extra/24-game/tags.txt @@ -1 +1,2 @@ demos +games \ No newline at end of file diff --git a/extra/animations/animations-docs.factor b/extra/animations/animations-docs.factor index 6a1e89a28e..000c0ce4cc 100644 --- a/extra/animations/animations-docs.factor +++ b/extra/animations/animations-docs.factor @@ -1,34 +1,65 @@ USING: help.markup help.syntax ; -IN: extra.animations +IN: animations HELP: animate ( quot duration -- ) + { $values { "quot" "a quot which uses " { $link progress } } { "duration" "a duration of time" } } -{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once." } -{ $example - "USING: extra.animations calendar threads prettyprint ;" - "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;" - "46 ms elapsed\n17 ms elapsed" +{ $description + { $link animate } " calls " { $link reset-progress } + " , then continously calls the given quot until the" + " duration of time has elapsed. The quot should use " + { $link progress } " at least once." +} +{ $examples + { $unchecked-example + "USING: animations calendar threads prettyprint ;" + "[ 1 sleep progress unparse write \" ms elapsed\" print ] " + "1/20 seconds animate ;" + "46 ms elapsed\n17 ms elapsed" + } + { $notes "The amount of time elapsed between these iterations will very." } } ; HELP: reset-progress ( -- ) -{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ; +{ $description + "Initiates the timer. Call this before using " + "a loop which makes use of " { $link progress } "." +} ; HELP: progress ( -- time ) { $values { "time" "an integer" } } -{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." } -{ $example - "USING: extra.animations threads prettyprint ;" - "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;" - "31 ms elapsed\n18 ms elapsed\n16 ms elapsed" +{ $description + "Gives the time elapsed since the last time" + " this word was called, in milliseconds." +} +{ $examples + { $unchecked-example + "USING: animations threads prettyprint ;" + "reset-progress 3 " + "[ 1 sleep progress unparse write \"ms elapsed\" print ] " + "times ;" + "31 ms elapsed\n18 ms elapsed\n16 ms elapsed" + } + { $notes "The amount of time elapsed between these iterations will very." } } ; -ARTICLE: "extra.animations" "Animations" -"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!" +ARTICLE: "animations" "Animations" +"Provides a lightweight framework for properly simulating continuous" +" functions of real time. This framework helps one create animations " +"that use rates which do not change across platforms. The speed of the " +"computer should correlate with the smoothness of the animation, not " +"the speed of the animation!" { $subsection animate } { $subsection reset-progress } { $subsection progress } -{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ; -ABOUT: "extra.animations" \ No newline at end of file +! A little talk about when to use progress and when to use animate + { $link progress } " specifically provides the length of time since " + { $link reset-progress } " was called, and also calls " + { $link reset-progress } " as its last action. This can be directly " + "used when one's quote runs for a specific number of iterations, instead " + "of a length of time. If the animation is like most, and is expected to " + "run for a specific length of time, " { $link animate } " should be used." ; +ABOUT: "animations" \ No newline at end of file diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index 7efd618bbf..803536a51c 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -2,11 +2,16 @@ USING: kernel shuffle system locals prettyprint math io namespaces threads calendar ; -IN: extra.animations +IN: animations SYMBOL: last-loop +SYMBOL: sleep-period + : reset-progress ( -- ) millis last-loop set ; +! : my-progress ( -- progress ) millis : progress ( -- progress ) millis last-loop get - reset-progress ; +: progress-peek ( -- progress ) millis last-loop get - ; : set-end ( duration -- end-time ) dt>milliseconds millis + ; -: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; -: animate ( quot duration -- ) reset-progress set-end loop ; \ No newline at end of file +: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline +: animate ( quot duration -- ) reset-progress set-end loop ; inline +: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline \ No newline at end of file diff --git a/extra/animations/authors.txt b/extra/animations/authors.txt index dac0cb42fe..137b1605da 100644 --- a/extra/animations/authors.txt +++ b/extra/animations/authors.txt @@ -1 +1 @@ -Reginald Keith Ford II \ No newline at end of file +Reginald Ford \ No newline at end of file diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor index 0bf8270088..c7e1aa4fbf 100644 --- a/extra/assocs/lib/lib-tests.factor +++ b/extra/assocs/lib/lib-tests.factor @@ -1,4 +1,17 @@ +USING: kernel tools.test sequences vectors assocs.lib ; IN: assocs.lib.tests -USING: assocs.lib tools.test vectors ; { 1 1 } [ [ ?push ] histogram ] must-infer-as + +! substitute +[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test +[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test + +[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test +[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test + +[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test +[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test +[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test +[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test + diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 5036a13d78..ed9b4bf0c4 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -37,3 +37,13 @@ IN: assocs.lib H{ } clone [ swap [ change-at ] 2curry assoc-each ] keep ; inline + +: ?at ( obj assoc -- value/obj ? ) + dupd at* [ [ nip ] [ drop ] if ] keep ; + +: if-at ( obj assoc quot1 quot2 -- ) + [ ?at ] 2dip if ; inline + +: when-at ( obj assoc quot -- ) [ ] if-at ; inline + +: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 3c1a794121..db2c50173c 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot ) tri* if ] with-scope ; inline +: cut-amb ( -- ) + f failure set ; diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor index 20099d225a..f5398582c9 100644 --- a/extra/cfdg/models/rules08/rules08.factor +++ b/extra/cfdg/models/rules08/rules08.factor @@ -17,37 +17,21 @@ DEFER: line : ligne ( -- ) { - { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] do } + { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] } { 0.5 [ ] } } - call-random-weighted ; + rules ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: line ( -- ) [ insct ligne ] recursive ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: line ( -- ) { [ insct ligne ] } rule ; : sole ( -- ) - [ - { - { - 1 [ - [ 1 brightness 0.5 saturation ligne ] do - [ 140 r 1 hue sole ] do - ] - } - { 0.01 [ ] } - } - call-random-weighted - ] - recursive ; + { + { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] } + { 0.01 [ ] } + } + rules ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: centre ( -- ) - [ 1 b 5 s circle ] do - [ sole ] do ; +: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index fe2f3556ef..cde3b4d259 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -11,3 +11,12 @@ HELP: generate "[ 20 random-prime ] [ 4 mod 3 = ] generate ." "526367" } ; + +HELP: %chance +{ $values { "quot" quotation } { "n" integer } } +{ $description "Calls the quotation " { $snippet "n" } " percent of the time." } +{ $unchecked-example + "USING: io ;" + "[ \"hello, world! maybe.\" print ] 50 %chance" + "" +} ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index a7d5e4cf58..3b92844b3f 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel combinators fry namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges -generalizations macros continuations locals ; +generalizations macros continuations random locals ; IN: combinators.lib @@ -31,6 +31,8 @@ IN: combinators.lib ! Generalized versions of core combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: quad ( x p q r s -- ) >r >r >r keep r> keep r> keep r> call ; inline + : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline @@ -137,7 +139,7 @@ MACRO: multikeep ( word out-indexes -- ... ) [ drop ] rot compose attempt-all ; inline : do-while ( pred body tail -- ) - >r tuck 2slip r> while ; + >r tuck 2slip r> while ; inline : generate ( generator predicate -- obj ) [ dup ] swap [ dup [ nip ] unless not ] 3compose @@ -147,3 +149,5 @@ MACRO: predicates ( seq -- quot/f ) dup [ 1quotation [ drop ] prepend ] map >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix [ cond ] curry ; + +: %chance ( quot integer -- ) 100 random > swap when ; inline diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index dca727b9dc..29ccc345d3 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -56,8 +56,7 @@ TUPLE: link attributes clickable ; : trim-text ( vector -- vector' ) [ dup name>> text = [ - [ text>> [ blank? ] trim ] keep - [ set-tag-text ] keep + [ [ blank? ] trim ] change-text ] when ] map ; @@ -140,6 +139,12 @@ TUPLE: link attributes clickable ; : href-contains? ( str tag -- ? ) attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; +: find-hrefs ( vector -- vector' ) + find-links + [ [ + [ name>> "a" = ] + [ attributes>> "href" swap key? ] bi and ] filter + ] map sift [ [ attributes>> "href" swap at ] map ] map concat ; : find-forms ( vector -- vector' ) "form" over find-opening-tags-by-name @@ -167,8 +172,7 @@ TUPLE: link attributes clickable ; [ { { [ dup name>> "form" = ] - [ "form action: " write attributes>> "action" swap at print - ] } + [ "form action: " write attributes>> "action" swap at print ] } { [ dup name>> "input" = ] [ input. ] } [ drop ] } cond diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index 0e98c1b998..9757f70a67 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -2,19 +2,19 @@ USING: html.parser kernel tools.test ; IN: html.parser.tests [ - V{ T{ tag f "html" H{ } f f f } } + V{ T{ tag f "html" H{ } f f } } ] [ "" parse-html ] unit-test [ - V{ T{ tag f "html" H{ } f f t } } + V{ T{ tag f "html" H{ } f t } } ] [ "" parse-html ] unit-test [ - V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } } + V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } ] [ "" parse-html ] unit-test [ - V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } } + V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } ] [ "" parse-html ] unit-test [ @@ -26,7 +26,6 @@ V{ H{ { "baz" "\"quux\"" } { "foo" "bar's" } } f f - f } } ] [ "" parse-html ] unit-test @@ -39,25 +38,25 @@ V{ { "foo" "bar" } { "href" "http://factorcode.org/" } { "baz" "quux" } - } f f f } + } f f } } ] [ "" parse-html ] unit-test [ V{ - T{ tag f "html" H{ } f f f } - T{ tag f "head" H{ } f f f } - T{ tag f "head" H{ } f f t } - T{ tag f "html" H{ } f f t } + T{ tag f "html" H{ } f f } + T{ tag f "head" H{ } f f } + T{ tag f "head" H{ } f t } + T{ tag f "html" H{ } f t } } ] [ "Spagna ( name attributes closing? -- tag ) - { set-tag-name set-tag-attributes set-tag-closing? } - tag construct ; + tag new + swap >>closing? + swap >>attributes + swap >>name ; -: make-tag ( str attribs -- tag ) +: make-tag ( string attribs -- tag ) >r [ closing-tag? ] keep "/" trim1 r> rot ; -: make-text-tag ( str -- tag ) - T{ tag f text } clone [ set-tag-text ] keep ; +: make-text-tag ( string -- tag ) + tag new + text >>name + swap >>text ; -: make-comment-tag ( str -- tag ) - T{ tag f comment } clone [ set-tag-text ] keep ; +: make-comment-tag ( string -- tag ) + tag new + comment >>name + swap >>text ; -: make-dtd-tag ( str -- tag ) - T{ tag f dtd } clone [ set-tag-text ] keep ; +: make-dtd-tag ( string -- tag ) + tag new + dtd >>name + swap >>text ; -: read-whitespace ( -- str ) +: read-whitespace ( -- string ) [ get-char blank? not ] take-until ; -: read-whitespace* ( -- ) - read-whitespace drop ; +: read-whitespace* ( -- ) read-whitespace drop ; -: read-token ( -- str ) +: read-token ( -- string ) read-whitespace* [ get-char blank? ] take-until ; -: read-single-quote ( -- str ) +: read-single-quote ( -- string ) [ get-char CHAR: ' = ] take-until ; -: read-double-quote ( -- str ) +: read-double-quote ( -- string ) [ get-char CHAR: " = ] take-until ; -: read-quote ( -- str ) - get-char next* CHAR: ' = [ - read-single-quote - ] [ - read-double-quote - ] if next* ; +: read-quote ( -- string ) + get-char next* CHAR: ' = + [ read-single-quote ] [ read-double-quote ] if next* ; -: read-key ( -- str ) +: read-key ( -- string ) read-whitespace* - [ get-char CHAR: = = get-char blank? or ] take-until ; + [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ; : read-= ( -- ) read-whitespace* [ get-char CHAR: = = ] take-until drop next* ; -: read-value ( -- str ) +: read-value ( -- string ) read-whitespace* - get-char quote? [ - read-quote - ] [ - read-token - ] if ; + get-char quote? [ read-quote ] [ read-token ] if + [ blank? ] trim ; : read-comment ( -- ) "-->" take-string* make-comment-tag push-tag ; @@ -95,14 +92,14 @@ SYMBOL: tagstack [ get-char CHAR: > = get-char CHAR: < = or ] take-until get-char CHAR: < = [ next* ] unless ; -: read-< ( -- str ) +: read-< ( -- string ) next* get-char CHAR: ! = [ read-bang f ] [ read-tag ] if ; -: read-until-< ( -- str ) +: read-until-< ( -- string ) [ get-char CHAR: < = ] take-until ; : parse-text ( -- ) @@ -129,11 +126,9 @@ SYMBOL: tagstack ] string-parse ; : parse-tag ( -- ) - read-< dup empty? [ - drop - ] [ + read-< [ (parse-tag) make-tag push-tag - ] if ; + ] unless-empty ; : (parse-html) ( -- ) get-next [ @@ -143,13 +138,7 @@ SYMBOL: tagstack ] when ; : tag-parse ( quot -- vector ) - [ - V{ } clone tagstack set - string-parse - ] with-scope ; + V{ } clone tagstack [ string-parse ] with-variable ; : parse-html ( string -- vector ) - [ - (parse-html) - tagstack get - ] tag-parse ; + [ (parse-html) tagstack get ] tag-parse ; diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor index d352a97688..4419eec70e 100644 --- a/extra/html/parser/printer/printer.factor +++ b/extra/html/parser/printer/printer.factor @@ -1,127 +1,89 @@ -USING: assocs html.parser html.parser.utils combinators +USING: accessors assocs html.parser html.parser.utils combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint quotations sequences splitting strings ; IN: html.parser.printer -SYMBOL: no-section -SYMBOL: html -SYMBOL: head -SYMBOL: body -TUPLE: state section ; +SYMBOL: printer -! TUPLE: text bold? underline? strikethrough? ; +TUPLE: html-printer ; +TUPLE: text-printer < html-printer ; +TUPLE: src-printer < html-printer ; +TUPLE: html-prettyprinter < html-printer ; -TUPLE: text-printer ; -TUPLE: ui-printer ; -TUPLE: src-printer ; -TUPLE: html-prettyprinter ; -UNION: printer text-printer ui-printer src-printer html-prettyprinter ; -HOOK: print-tag printer ( tag -- ) -HOOK: print-text-tag printer ( tag -- ) -HOOK: print-comment-tag printer ( tag -- ) -HOOK: print-dtd-tag printer ( tag -- ) -HOOK: print-opening-named-tag printer ( tag -- ) -HOOK: print-closing-named-tag printer ( tag -- ) +HOOK: print-text-tag html-printer ( tag -- ) +HOOK: print-comment-tag html-printer ( tag -- ) +HOOK: print-dtd-tag html-printer ( tag -- ) +HOOK: print-opening-tag html-printer ( tag -- ) +HOOK: print-closing-tag html-printer ( tag -- ) -: print-tags ( vector -- ) - [ print-tag ] each ; +ERROR: unknown-tag-error tag ; + +: print-tag ( tag -- ) + { + { [ dup name>> text = ] [ print-text-tag ] } + { [ dup name>> comment = ] [ print-comment-tag ] } + { [ dup name>> dtd = ] [ print-dtd-tag ] } + { [ dup [ name>> string? ] [ closing?>> ] bi and ] + [ print-closing-tag ] } + { [ dup name>> string? ] + [ print-opening-tag ] } + [ unknown-tag-error ] + } cond ; + +: print-tags ( vector -- ) [ print-tag ] each ; : html-text. ( vector -- ) - [ - T{ text-printer } printer set - print-tags - ] with-scope ; + T{ text-printer } html-printer [ print-tags ] with-variable ; : html-src. ( vector -- ) - [ - T{ src-printer } printer set - print-tags - ] with-scope ; + T{ src-printer } html-printer [ print-tags ] with-variable ; -M: printer print-text-tag ( tag -- ) - tag-text write ; +M: html-printer print-text-tag ( tag -- ) text>> write ; -M: printer print-comment-tag ( tag -- ) - "" write ; +M: html-printer print-comment-tag ( tag -- ) + "" write ; -M: printer print-dtd-tag ( tag -- ) - "" write ; - -M: printer print-opening-named-tag ( tag -- ) - dup tag-name { - { "html" [ drop ] } - { "head" [ drop ] } - { "body" [ drop ] } - { "title" [ "Title: " write tag-text print ] } - } case ; - -M: printer print-closing-named-tag ( tag -- ) - drop ; +M: html-printer print-dtd-tag ( tag -- ) + "> write ">" write ; : print-attributes ( hashtable -- ) - [ - swap bl write "=" write ?quote write - ] assoc-each ; + [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ; -M: src-printer print-opening-named-tag ( tag -- ) +M: src-printer print-opening-tag ( tag -- ) "<" write - [ tag-name write ] - [ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi + [ name>> write ] + [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi ">" write ; -M: src-printer print-closing-named-tag ( tag -- ) +M: src-printer print-closing-tag ( tag -- ) "> write ">" write ; SYMBOL: tab-width SYMBOL: #indentations +SYMBOL: tagstack -: html-pp ( vector -- ) +: prettyprint-html ( vector -- ) [ - 0 #indentations set + T{ html-prettyprinter } printer set + V{ } clone tagstack set 2 tab-width set - + 0 #indentations set + print-tags ] with-scope ; : print-tabs ( -- ) tab-width get #indentations get * CHAR: \s write ; -M: html-prettyprinter print-opening-named-tag ( tag -- ) +M: html-prettyprinter print-opening-tag ( tag -- ) print-tabs "<" write - tag-name write + name>> write ">\n" write ; -M: html-prettyprinter print-closing-named-tag ( tag -- ) +M: html-prettyprinter print-closing-tag ( tag -- ) "> write ">" write ; - -ERROR: unknown-tag-error tag ; - -M: printer print-tag ( tag -- ) - { - { [ dup tag-name text = ] [ print-text-tag ] } - { [ dup tag-name comment = ] [ print-comment-tag ] } - { [ dup tag-name dtd = ] [ print-dtd-tag ] } - { [ dup tag-name string? over tag-closing? and ] - [ print-closing-named-tag ] } - { [ dup tag-name string? ] - [ print-opening-named-tag ] } - [ unknown-tag-error ] - } cond ; - -! SYMBOL: tablestack -! : with-html-printer ( vector quot -- ) - ! [ V{ } clone tablestack set ] with-scope ; - -! { { 1 2 } { 3 4 } } -! H{ { table-gap { 10 10 } } } [ - ! [ [ [ [ . ] with-cell ] each ] with-row ] each -! ] tabular-output diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index c3372d750a..04b3687f7d 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -4,8 +4,7 @@ namespaces prettyprint quotations sequences splitting state-parser strings sequences.lib ; IN: html.parser.utils -: string-parse-end? ( -- ? ) - get-next not ; +: string-parse-end? ( -- ? ) get-next not ; : take-string* ( match -- string ) dup length @@ -16,17 +15,18 @@ IN: html.parser.utils [ ?head drop ] [ ?tail drop ] bi ; : single-quote ( str -- newstr ) - >r "'" r> "'" 3append ; + "'" swap "'" 3append ; : double-quote ( str -- newstr ) - >r "\"" r> "\"" 3append ; + "\"" swap "\"" 3append ; : quote ( str -- newstr ) CHAR: ' over member? [ double-quote ] [ single-quote ] if ; : quoted? ( str -- ? ) - [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ; + [ f ] + [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ; : ?quote ( str -- newstr ) dup quoted? [ quote ] unless ; diff --git a/extra/io/serial/authors.txt b/extra/io/serial/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/serial/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/serial/serial.factor b/extra/io/serial/serial.factor new file mode 100644 index 0000000000..c24f08906c --- /dev/null +++ b/extra/io/serial/serial.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types assocs combinators destructors +kernel math math.bitfields math.parser sequences summary system +vocabs.loader ; +IN: io.serial + +TUPLE: serial stream path baud + termios iflag oflag cflag lflag ; + +ERROR: invalid-baud baud ; +M: invalid-baud summary ( invalid-baud -- string ) + "Baud rate " + swap baud>> number>string + " not supported" 3append ; + +HOOK: lookup-baud os ( m -- n ) +HOOK: open-serial os ( serial -- stream ) + +{ + { [ os unix? ] [ "io.serial.unix" ] } +} cond require diff --git a/extra/io/serial/summary.txt b/extra/io/serial/summary.txt new file mode 100644 index 0000000000..5ccd99dbaa --- /dev/null +++ b/extra/io/serial/summary.txt @@ -0,0 +1 @@ +Serial port library diff --git a/extra/io/serial/tags.txt b/extra/io/serial/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor new file mode 100644 index 0000000000..3c5ce62c63 --- /dev/null +++ b/extra/io/serial/unix/bsd/bsd.factor @@ -0,0 +1,86 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel math.bitfields sequences system io.serial ; +IN: io.serial.unix + +M: bsd lookup-baud ( m -- n ) + dup { + 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 + 7200 9600 14400 19200 28800 38400 57600 76800 115200 + 230400 460800 921600 + } member? [ invalid-baud ] unless ; + +: TCSANOW 0 ; inline +: TCSADRAIN 1 ; inline +: TCSAFLUSH 2 ; inline +: TCSASOFT HEX: 10 ; inline + +: TCIFLUSH 1 ; inline +: TCOFLUSH 2 ; inline +: TCIOFLUSH 3 ; inline +: TCOOFF 1 ; inline +: TCOON 2 ; inline +: TCIOFF 3 ; inline +: TCION 4 ; inline + +! iflags +: IGNBRK HEX: 00000001 ; inline +: BRKINT HEX: 00000002 ; inline +: IGNPAR HEX: 00000004 ; inline +: PARMRK HEX: 00000008 ; inline +: INPCK HEX: 00000010 ; inline +: ISTRIP HEX: 00000020 ; inline +: INLCR HEX: 00000040 ; inline +: IGNCR HEX: 00000080 ; inline +: ICRNL HEX: 00000100 ; inline +: IXON HEX: 00000200 ; inline +: IXOFF HEX: 00000400 ; inline +: IXANY HEX: 00000800 ; inline +: IMAXBEL HEX: 00002000 ; inline +: IUTF8 HEX: 00004000 ; inline + +! oflags +: OPOST HEX: 00000001 ; inline +: ONLCR HEX: 00000002 ; inline +: OXTABS HEX: 00000004 ; inline +: ONOEOT HEX: 00000008 ; inline + +! cflags +: CIGNORE HEX: 00000001 ; inline +: CSIZE HEX: 00000300 ; inline +: CS5 HEX: 00000000 ; inline +: CS6 HEX: 00000100 ; inline +: CS7 HEX: 00000200 ; inline +: CS8 HEX: 00000300 ; inline +: CSTOPB HEX: 00000400 ; inline +: CREAD HEX: 00000800 ; inline +: PARENB HEX: 00001000 ; inline +: PARODD HEX: 00002000 ; inline +: HUPCL HEX: 00004000 ; inline +: CLOCAL HEX: 00008000 ; inline +: CCTS_OFLOW HEX: 00010000 ; inline +: CRTS_IFLOW HEX: 00020000 ; inline +: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline +: CDTR_IFLOW HEX: 00040000 ; inline +: CDSR_OFLOW HEX: 00080000 ; inline +: CCAR_OFLOW HEX: 00100000 ; inline +: MDMBUF HEX: 00100000 ; inline + +! lflags +: ECHOKE HEX: 00000001 ; inline +: ECHOE HEX: 00000002 ; inline +: ECHOK HEX: 00000004 ; inline +: ECHO HEX: 00000008 ; inline +: ECHONL HEX: 00000010 ; inline +: ECHOPRT HEX: 00000020 ; inline +: ECHOCTL HEX: 00000040 ; inline +: ISIG HEX: 00000080 ; inline +: ICANON HEX: 00000100 ; inline +: ALTWERASE HEX: 00000200 ; inline +: IEXTEN HEX: 00000400 ; inline +: EXTPROC HEX: 00000800 ; inline +: TOSTOP HEX: 00400000 ; inline +: FLUSHO HEX: 00800000 ; inline +: NOKERNINFO HEX: 02000000 ; inline +: PENDIN HEX: 20000000 ; inline +: NOFLSH HEX: 80000000 ; inline diff --git a/extra/io/serial/unix/bsd/tags.txt b/extra/io/serial/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/linux/linux.factor b/extra/io/serial/unix/linux/linux.factor new file mode 100644 index 0000000000..342ff4499f --- /dev/null +++ b/extra/io/serial/unix/linux/linux.factor @@ -0,0 +1,130 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs alien.syntax kernel io.serial system unix ; +IN: io.serial.unix + +: TCSANOW 0 ; inline +: TCSADRAIN 1 ; inline +: TCSAFLUSH 2 ; inline + +: TCIFLUSH 0 ; inline +: TCOFLUSH 1 ; inline +: TCIOFLUSH 2 ; inline + +: TCOOFF 0 ; inline +: TCOON 1 ; inline +: TCIOFF 2 ; inline +: TCION 3 ; inline + +! iflag +: IGNBRK OCT: 0000001 ; inline +: BRKINT OCT: 0000002 ; inline +: IGNPAR OCT: 0000004 ; inline +: PARMRK OCT: 0000010 ; inline +: INPCK OCT: 0000020 ; inline +: ISTRIP OCT: 0000040 ; inline +: INLCR OCT: 0000100 ; inline +: IGNCR OCT: 0000200 ; inline +: ICRNL OCT: 0000400 ; inline +: IUCLC OCT: 0001000 ; inline +: IXON OCT: 0002000 ; inline +: IXANY OCT: 0004000 ; inline +: IXOFF OCT: 0010000 ; inline +: IMAXBEL OCT: 0020000 ; inline +: IUTF8 OCT: 0040000 ; inline + +! oflag +: OPOST OCT: 0000001 ; inline +: OLCUC OCT: 0000002 ; inline +: ONLCR OCT: 0000004 ; inline +: OCRNL OCT: 0000010 ; inline +: ONOCR OCT: 0000020 ; inline +: ONLRET OCT: 0000040 ; inline +: OFILL OCT: 0000100 ; inline +: OFDEL OCT: 0000200 ; inline +: NLDLY OCT: 0000400 ; inline +: NL0 OCT: 0000000 ; inline +: NL1 OCT: 0000400 ; inline +: CRDLY OCT: 0003000 ; inline +: CR0 OCT: 0000000 ; inline +: CR1 OCT: 0001000 ; inline +: CR2 OCT: 0002000 ; inline +: CR3 OCT: 0003000 ; inline +: TABDLY OCT: 0014000 ; inline +: TAB0 OCT: 0000000 ; inline +: TAB1 OCT: 0004000 ; inline +: TAB2 OCT: 0010000 ; inline +: TAB3 OCT: 0014000 ; inline +: BSDLY OCT: 0020000 ; inline +: BS0 OCT: 0000000 ; inline +: BS1 OCT: 0020000 ; inline +: FFDLY OCT: 0100000 ; inline +: FF0 OCT: 0000000 ; inline +: FF1 OCT: 0100000 ; inline + +! cflags +: CSIZE OCT: 0000060 ; inline +: CS5 OCT: 0000000 ; inline +: CS6 OCT: 0000020 ; inline +: CS7 OCT: 0000040 ; inline +: CS8 OCT: 0000060 ; inline +: CSTOPB OCT: 0000100 ; inline +: CREAD OCT: 0000200 ; inline +: PARENB OCT: 0000400 ; inline +: PARODD OCT: 0001000 ; inline +: HUPCL OCT: 0002000 ; inline +: CLOCAL OCT: 0004000 ; inline +: CIBAUD OCT: 002003600000 ; inline +: CRTSCTS OCT: 020000000000 ; inline + +! lflags +: ISIG OCT: 0000001 ; inline +: ICANON OCT: 0000002 ; inline +: XCASE OCT: 0000004 ; inline +: ECHO OCT: 0000010 ; inline +: ECHOE OCT: 0000020 ; inline +: ECHOK OCT: 0000040 ; inline +: ECHONL OCT: 0000100 ; inline +: NOFLSH OCT: 0000200 ; inline +: TOSTOP OCT: 0000400 ; inline +: ECHOCTL OCT: 0001000 ; inline +: ECHOPRT OCT: 0002000 ; inline +: ECHOKE OCT: 0004000 ; inline +: FLUSHO OCT: 0010000 ; inline +: PENDIN OCT: 0040000 ; inline +: IEXTEN OCT: 0100000 ; inline + +M: linux lookup-baud ( n -- n ) + dup H{ + { 0 OCT: 0000000 } + { 50 OCT: 0000001 } + { 75 OCT: 0000002 } + { 110 OCT: 0000003 } + { 134 OCT: 0000004 } + { 150 OCT: 0000005 } + { 200 OCT: 0000006 } + { 300 OCT: 0000007 } + { 600 OCT: 0000010 } + { 1200 OCT: 0000011 } + { 1800 OCT: 0000012 } + { 2400 OCT: 0000013 } + { 4800 OCT: 0000014 } + { 9600 OCT: 0000015 } + { 19200 OCT: 0000016 } + { 38400 OCT: 0000017 } + { 57600 OCT: 0010001 } + { 115200 OCT: 0010002 } + { 230400 OCT: 0010003 } + { 460800 OCT: 0010004 } + { 500000 OCT: 0010005 } + { 576000 OCT: 0010006 } + { 921600 OCT: 0010007 } + { 1000000 OCT: 0010010 } + { 1152000 OCT: 0010011 } + { 1500000 OCT: 0010012 } + { 2000000 OCT: 0010013 } + { 2500000 OCT: 0010014 } + { 3000000 OCT: 0010015 } + { 3500000 OCT: 0010016 } + { 4000000 OCT: 0010017 } + } at* [ nip ] [ drop invalid-baud ] if ; diff --git a/extra/io/serial/unix/linux/tags.txt b/extra/io/serial/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/tags.txt b/extra/io/serial/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/termios/bsd/bsd.factor b/extra/io/serial/unix/termios/bsd/bsd.factor new file mode 100644 index 0000000000..414ec98438 --- /dev/null +++ b/extra/io/serial/unix/termios/bsd/bsd.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel sequences system ; +IN: io.serial.unix.termios + +: NCCS 20 ; inline + +TYPEDEF: uint tcflag_t +TYPEDEF: uchar cc_t +TYPEDEF: uint speed_t + +C-STRUCT: termios + { "tcflag_t" "iflag" } ! input mode flags + { "tcflag_t" "oflag" } ! output mode flags + { "tcflag_t" "cflag" } ! control mode flags + { "tcflag_t" "lflag" } ! local mode flags + { { "cc_t" NCCS } "cc" } ! control characters + { "speed_t" "ispeed" } ! input speed + { "speed_t" "ospeed" } ; ! output speed diff --git a/extra/io/serial/unix/termios/bsd/tags.txt b/extra/io/serial/unix/termios/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/termios/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/termios/linux/linux.factor b/extra/io/serial/unix/termios/linux/linux.factor new file mode 100644 index 0000000000..c7da10a6f5 --- /dev/null +++ b/extra/io/serial/unix/termios/linux/linux.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel system unix ; +IN: io.serial.unix.termios + +: NCCS 32 ; inline + +TYPEDEF: uchar cc_t +TYPEDEF: uint speed_t +TYPEDEF: uint tcflag_t + +C-STRUCT: termios + { "tcflag_t" "iflag" } ! input mode flags + { "tcflag_t" "oflag" } ! output mode flags + { "tcflag_t" "cflag" } ! control mode flags + { "tcflag_t" "lflag" } ! local mode flags + { "cc_t" "line" } ! line discipline + { { "cc_t" NCCS } "cc" } ! control characters + { "speed_t" "ispeed" } ! input speed + { "speed_t" "ospeed" } ; ! output speed diff --git a/extra/io/serial/unix/termios/linux/tags.txt b/extra/io/serial/unix/termios/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/termios/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/termios/tags.txt b/extra/io/serial/unix/termios/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/serial/unix/termios/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/serial/unix/termios/termios.factor b/extra/io/serial/unix/termios/termios.factor new file mode 100644 index 0000000000..e5ccd37e87 --- /dev/null +++ b/extra/io/serial/unix/termios/termios.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators system vocabs.loader ; +IN: io.serial.unix.termios + +{ + { [ os linux? ] [ "io.serial.unix.termios.linux" ] } + { [ os bsd? ] [ "io.serial.unix.termios.bsd" ] } +} cond require diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor new file mode 100644 index 0000000000..bbfd10b943 --- /dev/null +++ b/extra/io/serial/unix/unix-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math.bitfields serial serial.unix ; +IN: io.serial.unix + +: serial-obj ( -- obj ) + serial new + "/dev/ttyS0" >>path + 19200 >>baud + { IGNPAR ICRNL } flags >>iflag + { } flags >>oflag + { CS8 CLOCAL CREAD } flags >>cflag + { ICANON } flags >>lflag ; + +: serial-test ( -- serial ) + serial-obj + open-serial + dup get-termios >>termios + dup configure-termios + dup tciflush + dup apply-termios ; diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor new file mode 100644 index 0000000000..ed60d941dd --- /dev/null +++ b/extra/io/serial/unix/unix.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.syntax combinators io.ports +io.streams.duplex io.unix.backend system kernel math math.bitfields +vocabs.loader unix io.serial io.serial.unix.termios ; +IN: io.serial.unix + +<< { + { [ os linux? ] [ "io.serial.unix.linux" ] } + { [ os bsd? ] [ "io.serial.unix.bsd" ] } +} cond require >> + +FUNCTION: speed_t cfgetispeed ( termios* t ) ; +FUNCTION: speed_t cfgetospeed ( termios* t ) ; +FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ; +FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ; +FUNCTION: int tcgetattr ( int i1, termios* t ) ; +FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ; +FUNCTION: int tcdrain ( int i1 ) ; +FUNCTION: int tcflow ( int i1, int i2 ) ; +FUNCTION: int tcflush ( int i1, int i2 ) ; +FUNCTION: int tcsendbreak ( int i1, int i2 ) ; +FUNCTION: void cfmakeraw ( termios* t ) ; +FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ; + +: fd>duplex-stream ( fd -- duplex-stream ) + init-fd + [ ] [ ] bi ; + +: open-rw ( path -- fd ) O_RDWR file-mode open-file ; +: ( path -- stream ) open-rw fd>duplex-stream ; + +M: unix open-serial ( serial -- serial' ) + path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file + fd>duplex-stream ; + +: serial-fd ( serial -- fd ) + stream>> in>> handle>> fd>> ; + +: get-termios ( serial -- termios ) + serial-fd + "termios" [ tcgetattr io-error ] keep ; + +: configure-termios ( serial -- ) + dup termios>> + { + [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ] + [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ] + [ + [ + [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor + ] dip set-termios-cflag + ] + [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ] + } 2cleave ; + +: tciflush ( serial -- ) + serial-fd TCIFLUSH tcflush io-error ; + +: apply-termios ( serial -- ) + [ serial-fd TCSANOW ] + [ termios>> ] bi tcsetattr io-error ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 1b338df442..932bdda472 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,190 +1,178 @@ USING: kernel tools.test accessors arrays sequences qualified - io.streams.string io.streams.duplex namespaces threads + io io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests -! Utilities -: ( lines -- stream ) - "\n" join ; +! Streams for testing +TUPLE: mb-writer lines last-line disposed ; +TUPLE: mb-reader lines disposed ; +: ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ; +: ( -- mb-reader ) f mb-reader boa ; +: push-line ( line test-reader-stream -- ) lines>> mailbox-put ; +: ( -- stream ) ; +M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ; +M: mb-writer stream-flush ( mb-writer -- ) drop ; +M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ; +M: mb-writer stream-nl ( mb-writer -- ) + [ [ last-line>> concat ] [ lines>> ] bi push ] keep + V{ } clone >>last-line drop ; -: make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; +: spawn-client ( lines listeners -- irc-client ) + "someserver" irc-port "factorbot" f + + t >>is-running + >>stream + dup [ spawn-irc yield ] with-irc-client ; -: set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; +! to be used inside with-irc-client quotations +: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ; +: %join ( channel -- ) irc> add-listener ; +: %push-line ( line -- ) irc> stream>> in>> push-line yield ; -: with-dummy-client ( irc-client quot -- ) - [ current-irc-client ] dip with-variable ; inline +: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message ) + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; -{ "" } make-client dup "factorbot" set-nick [ - { t } [ irc> profile>> nickname>> me? ] unit-test +: with-irc ( quot: ( -- ) -- ) + [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline - { "factorbot" } [ irc> profile>> nickname>> ] unit-test +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! TESTS +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test +[ { t } [ irc> profile>> nickname>> me? ] unit-test - { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line irc-message-origin ] unit-test + { "factorbot" } [ irc> profile>> nickname>> ] unit-test - { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line irc-message-origin ] unit-test -] with-dummy-client + { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + + { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line forward-name ] unit-test + + { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" + parse-irc-line forward-name ] unit-test +] with-irc ! Test login and nickname set -{ "factorbot" } [ - { "NOTICE AUTH :*** Looking up your hostname..." - "NOTICE AUTH :*** Checking ident" - "NOTICE AUTH :*** Found your hostname" - "NOTICE AUTH :*** No identd (auth) response" - ":some.where 001 factorbot :Welcome factorbot" - } make-client - { [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ profile>> nickname>> ] - [ terminate-irc ] - } cleave ] unit-test +[ { "factorbot2" } [ + ":some.where 001 factorbot2 :Welcome factorbot2" %push-line + irc> profile>> nickname>> + ] unit-test +] with-irc -{ join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" - ":ircserver.net MODE #factortest +ns" - ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." - ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } make-client - { [ "factorbot" set-nick ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ join-messages>> 0.1 seconds mailbox-get-timeout ] - [ terminate-irc ] - } cleave - [ class ] [ trailing>> ] bi ] unit-test +[ { join_ "#factortest" } [ + { ":factorbot!n=factorbo@some.where JOIN :#factortest" + ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" + } [ %push-line ] each + irc> join-messages>> 0.1 seconds mailbox-get-timeout + [ class ] [ trailing>> ] bi + ] unit-test +] with-irc -{ +join+ "somebody" } [ - { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] - [ terminate-irc ] - } cleave - [ action>> ] [ nick>> ] bi - ] unit-test +[ { T{ participant-changed f "somebody" +join+ } } [ + "#factortest" [ %add-named-listener ] keep + ":somebody!n=somebody@some.where JOIN :#factortest" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc -{ privmsg "#factortest" "hello" } [ - { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test +[ { privmsg "#factortest" "hello" } [ + "#factortest" [ %add-named-listener ] keep + ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test +] with-irc -{ privmsg "factorbot" "hello" } [ - { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "somedude" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "somedude" ] dip at - [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test +[ { privmsg "factorbot" "hello" } [ + "somedude" [ %add-named-listener ] keep + ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test +] with-irc -! Participants lists tests -{ H{ { "somedude" +normal+ } } } [ - { ":somedude!n=user@isp.net JOIN :#factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { mode } [ + "#factortest" [ %add-named-listener ] keep + ":ircserver.net MODE #factortest +ns" %push-line + [ mode? ] read-matching-message class + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude!n=user@isp.net PART #factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +! Participant lists tests +[ { H{ { "somedude" +normal+ } } } [ + "#factortest" [ %add-named-listener ] keep + ":somedude!n=user@isp.net JOIN :#factortest" %push-line + participants>> + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude!n=user@isp.net QUIT" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net PART #factortest" %push-line + participants>> + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net QUIT" %push-line + participants>> + ] unit-test +] with-irc + +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line + participants>> + ] unit-test +] with-irc + +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user2@isp.net NICK :somedude2" %push-line + participants>> + ] unit-test +] with-irc ! Namelist change notification -{ T{ participant-changed f f f } } [ - { ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - ] unit-test +[ { T{ participant-changed f f f f } } [ + "#factortest" [ %add-named-listener ] keep + ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc -{ T{ participant-changed f "somedude" +part+ } } [ - { ":somedude!n=user@isp.net QUIT" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] - [ terminate-irc ] - } cleave - ] unit-test \ No newline at end of file +[ { T{ participant-changed f "somedude" +part+ f } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net QUIT" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc + +[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user2@isp.net NICK :somedude2" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 99922b1fb5..575c26972f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.private ; + ascii irc.messages ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -41,6 +41,7 @@ SYMBOL: +normal+ SYMBOL: +join+ SYMBOL: +part+ SYMBOL: +mode+ +SYMBOL: +nick+ ! listener objects : ( -- irc-listener ) irc-listener boa ; @@ -59,14 +60,13 @@ SYMBOL: +mode+ ! Message objects ! ====================================== -TUPLE: participant-changed nick action ; +TUPLE: participant-changed nick action parameter ; C: participant-changed SINGLETON: irc-listener-end ! send to a listener to stop its execution SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established -UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ @@ -100,33 +100,54 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; + : unregister-listener ( name -- ) irc> listeners>> [ at [ irc-listener-end ] dip to-listener ] [ delete-at ] 2bi ; -M: irc-listener to-listener ( message irc-listener -- ) - in-messages>> mailbox-put ; +: (remove-participant) ( nick listener -- ) + [ participants>> delete-at ] + [ [ +part+ f ] dip to-listener ] 2bi ; : remove-participant ( nick channel -- ) - listener> [ participants>> delete-at ] [ drop ] if* ; + listener> [ (remove-participant) ] [ drop ] if* ; : listeners-with-participant ( nick -- seq ) irc> listeners>> values [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] with filter ; +: to-listeners-with-participant ( message nickname -- ) + listeners-with-participant [ to-listener ] with each ; + : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ participants>> delete-at ] with each ; + dup listeners-with-participant [ (remove-participant) ] with each ; + +: notify-rename ( newnick oldnick listener -- ) + [ participant-changed new +nick+ >>action + [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ; + +: rename-participant ( newnick oldnick listener -- ) + [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ] + [ notify-rename ] 3bi ; + +: rename-participant-in-all ( oldnick newnick -- ) + swap dup listeners-with-participant [ rename-participant ] with with each ; : add-participant ( mode nick channel -- ) - listener> [ participants>> set-at ] [ 2drop ] if* ; + listener> [ + [ participants>> set-at ] + [ [ +join+ f ] dip to-listener ] 2bi + ] [ 2drop ] if* ; DEFER: me? : maybe-forward-join ( join -- ) - [ prefix>> parse-name me? ] keep and + [ irc-message-sender me? ] keep and [ irc> join-messages>> mailbox-put ] when* ; ! ====================================== @@ -158,78 +179,64 @@ DEFER: me? : me? ( string -- ? ) irc> profile>> nickname>> = ; -: irc-message-origin ( irc-message -- name ) - dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; +GENERIC: forward-name ( irc-message -- name ) +M: join forward-name ( join -- name ) trailing>> ; +M: part forward-name ( part -- name ) channel>> ; +M: kick forward-name ( kick -- name ) channel>> ; +M: mode forward-name ( mode -- name ) channel>> ; +M: privmsg forward-name ( privmsg -- name ) + dup name>> me? [ irc-message-sender ] [ name>> ] if ; -: broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ to-listener ] with each ; +UNION: single-forward join part kick mode privmsg ; +UNION: multiple-forward nick quit ; +UNION: broadcast-forward irc-end irc-disconnected irc-connected ; +GENERIC: forward-message ( irc-message -- ) -GENERIC: handle-participant-change ( irc-message -- ) - -M: join handle-participant-change ( join -- ) - [ prefix>> parse-name +join+ ] - [ trailing>> ] bi to-listener ; - -M: part handle-participant-change ( part -- ) - [ prefix>> parse-name +part+ ] - [ channel>> ] bi to-listener ; - -M: kick handle-participant-change ( kick -- ) - [ who>> +part+ ] - [ channel>> ] bi to-listener ; - -M: quit handle-participant-change ( quit -- ) - prefix>> parse-name - [ +part+ ] [ listeners-with-participant ] bi - [ to-listener ] with each ; - -GENERIC: handle-incoming-irc ( irc-message -- ) - -M: irc-message handle-incoming-irc ( irc-message -- ) +M: irc-message forward-message ( irc-message -- ) +server-listener+ listener> [ to-listener ] [ drop ] if* ; -M: logged-in handle-incoming-irc ( logged-in -- ) +M: single-forward forward-message ( forward-single -- ) + dup forward-name to-listener ; + +M: multiple-forward forward-message ( multiple-forward -- ) + dup irc-message-sender to-listeners-with-participant ; + +M: join forward-message ( join -- ) + [ maybe-forward-join ] [ call-next-method ] bi ; + +M: broadcast-forward forward-message ( irc-broadcasted-message -- ) + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: process-message ( irc-message -- ) + +M: object process-message ( object -- ) + drop ; + +M: logged-in process-message ( logged-in -- ) name>> irc> profile>> (>>nickname) ; -M: ping handle-incoming-irc ( ping -- ) +M: ping process-message ( ping -- ) trailing>> /PONG ; -M: nick-in-use handle-incoming-irc ( nick-in-use -- ) +M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; -M: privmsg handle-incoming-irc ( privmsg -- ) - dup irc-message-origin to-listener ; +M: join process-message ( join -- ) + [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; -M: join handle-incoming-irc ( join -- ) - { [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - [ handle-participant-change ] - } cleave ; +M: part process-message ( part -- ) + [ irc-message-sender ] [ channel>> ] bi remove-participant ; -M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] - [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] - [ handle-participant-change ] - tri ; +M: kick process-message ( kick -- ) + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + bi ; -M: kick handle-incoming-irc ( kick -- ) - { [ dup channel>> to-listener ] - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ handle-participant-change ] - [ dup who>> me? [ unregister-listener ] [ drop ] if ] - } cleave ; +M: quit process-message ( quit -- ) + irc-message-sender remove-participant-from-all ; -M: quit handle-incoming-irc ( quit -- ) - [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ handle-participant-change ] - [ prefix>> parse-name remove-participant-from-all ] - tri ; - -! FIXME: implement this -! M: mode handle-incoming-irc ( mode -- ) call-next-method ; -! M: nick handle-incoming-irc ( nick -- ) call-next-method ; +M: nick process-message ( nick -- ) + [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -238,22 +245,20 @@ M: quit handle-incoming-irc ( quit -- ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; -M: names-reply handle-incoming-irc ( names-reply -- ) +M: names-reply process-message ( names-reply -- ) [ names-reply>participants ] [ channel>> listener> ] bi [ [ (>>participants) ] - [ [ f f ] dip name>> to-listener ] bi + [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) - broadcast-message-to-listeners ; +: handle-incoming-irc ( irc-message -- ) + [ forward-message ] [ process-message ] bi ; ! ====================================== ! Client message handling ! ====================================== -GENERIC: handle-outgoing-irc ( obj -- ) - -M: irc-message handle-outgoing-irc ( irc-message -- ) +: handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; ! ====================================== @@ -367,7 +372,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) in-messages>> [ irc-connected ] dip mailbox-put ; : with-irc-client ( irc-client quot: ( -- ) -- ) - [ current-irc-client ] dip with-variable ; inline + [ \ current-irc-client ] dip with-variable ; inline PRIVATE> diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 7ee0f41ab0..20f4f1b277 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified EXCLUDE: sequences => join ; IN: irc.messages.tests -! Parsing tests + +{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + irc-message new ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line "someuser!n=user@some.where" >>prefix diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor old mode 100644 new mode 100755 index 3b9cf0af2c..201e8de9e7 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -46,7 +46,7 @@ GENERIC: irc-command-parameters ( irc-message -- seq ) M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; M: ping irc-command-parameters ( ping -- seq ) drop { } ; M: join irc-command-parameters ( join -- seq ) drop { } ; -M: part irc-command-parameters ( part -- seq ) name>> 1array ; +M: part irc-command-parameters ( part -- seq ) channel>> 1array ; M: quit irc-command-parameters ( quit -- seq ) drop { } ; M: nick irc-command-parameters ( nick -- seq ) drop { } ; M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; @@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string ) PRIVATE> +UNION: sender-in-prefix privmsg join part quit kick mode nick ; +GENERIC: irc-message-sender ( irc-message -- sender ) +M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) + prefix>> parse-name ; + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index 59f4526d23..184a2b4de8 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -1,13 +1,24 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel irc.client irc.messages irc.ui namespaces ; +USING: accessors kernel arrays irc.client irc.messages irc.ui namespaces ; IN: irc.ui.commands : say ( string -- ) - [ client get profile>> nickname>> print-irc ] - [ listener get write-message ] bi ; + irc-tab get + [ window>> client>> profile>> nickname>> print-irc ] + [ listener>> write-message ] 2bi ; + +: join ( string -- ) + irc-tab get window>> join-channel ; + +: query ( string -- ) + irc-tab get window>> query-nick ; + +: whois ( string -- ) + "WHOIS" swap { } clone swap + irc-tab get listener>> write-message ; : quote ( string -- ) drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index a524168d54..1aebfcbfcb 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations - irc.client irc.client.private irc.messages irc.messages.private + irc.client irc.client.private irc.messages irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -19,9 +19,12 @@ SYMBOL: listener SYMBOL: client -TUPLE: ui-window client tabs ; +TUPLE: ui-window < tabbed client ; -TUPLE: irc-tab < frame listener client userlist ; +M: ui-window ungraft* + client>> terminate-irc ; + +TUPLE: irc-tab < frame listener client window ; : write-color ( str color -- ) foreground associate format ; @@ -39,7 +42,7 @@ M: ping write-irc M: privmsg write-irc "<" blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep "> " blue write-color trailing>> write ; @@ -61,24 +64,24 @@ M: own-message write-irc M: join write-irc "* " dark-green write-color - prefix>> parse-name write + irc-message-sender write " has entered the channel." dark-green write-color ; M: part write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left the channel" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: quit write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left IRC" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: kick write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has kicked " dark-red write-color [ who>> write ] keep " from the channel" dark-red write-color @@ -89,7 +92,7 @@ M: kick write-irc M: mode write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has applied mode " blue write-color [ full-mode write ] keep " to " blue write-color @@ -97,7 +100,7 @@ M: mode write-irc M: nick write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " is now known as " blue write-color trailing>> write ; @@ -120,8 +123,11 @@ M: irc-listener-end write-irc M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE -: time-happened ( irc-message -- timestamp ) - [ timestamp>> ] [ 2drop now ] recover ; +GENERIC: time-happened ( message -- timestamp ) + +M: irc-message time-happened timestamp>> ; + +M: object time-happened drop now ; : print-irc ( irc-message -- ) [ time-happened timestamp>hms write " " write ] @@ -139,16 +145,6 @@ GENERIC: handle-inbox ( tab message -- ) : add-gadget-color ( pack seq color -- pack ) '[ , >>color add-gadget ] each ; -: update-participants ( tab -- ) - [ userlist>> [ clear-gadget ] keep ] - [ listener>> participants>> ] bi - [ +operator+ value-labels dark-green add-gadget-color ] - [ +voice+ value-labels blue add-gadget-color ] - [ +normal+ value-labels black add-gadget-color ] tri drop ; - -M: participant-changed handle-inbox - drop update-participants ; - M: object handle-inbox nip print-irc ; @@ -161,44 +157,60 @@ M: object handle-inbox [ swap display ] 2keep ; -TUPLE: irc-editor < editor outstream listener client ; +TUPLE: irc-editor < editor outstream tab ; : ( tab pane -- tab editor ) - over irc-editor new-editor - swap listener>> >>listener swap >>outstream - over client>> >>client ; + irc-editor new-editor + swap >>outstream ; : editor-send ( irc-editor -- ) { [ outstream>> ] - [ listener>> ] - [ client>> ] + [ [ irc-tab? ] find-parent ] [ editor-string ] [ "" swap set-editor-string ] } cleave - '[ , listener set , client set , parse-message ] with-output-stream ; + '[ , irc-tab set , parse-message ] with-output-stream ; irc-editor "general" f { { T{ key-down f f "RET" } editor-send } { T{ key-down f f "ENTER" } editor-send } } define-command-map -: ( listener client -- irc-tab ) - irc-tab new-frame - swap client>> >>client swap >>listener +: new-irc-tab ( listener ui-window class -- irc-tab ) + new-frame + swap >>window + swap >>listener [ @center grid-add ] keep @bottom grid-add ; -: ( listener client -- irc-tab ) - - [ @right grid-add ] keep >>userlist ; - -: ( listener client -- irc-tab ) - ; - M: irc-tab graft* - [ listener>> ] [ client>> ] bi add-listener ; + [ listener>> ] [ window>> client>> ] bi add-listener ; M: irc-tab ungraft* - [ listener>> ] [ client>> ] bi remove-listener ; + [ listener>> ] [ window>> client>> ] bi remove-listener ; + +TUPLE: irc-channel-tab < irc-tab userlist ; + +: ( listener ui-window -- irc-tab ) + irc-channel-tab new-irc-tab + [ @right grid-add ] keep >>userlist ; + +: update-participants ( tab -- ) + [ userlist>> [ clear-gadget ] keep ] + [ listener>> participants>> ] bi + [ +operator+ value-labels dark-green add-gadget-color ] + [ +voice+ value-labels blue add-gadget-color ] + [ +normal+ value-labels black add-gadget-color ] tri drop ; + +M: participant-changed handle-inbox + drop update-participants ; + +TUPLE: irc-server-tab < irc-tab ; + +: ( listener -- irc-tab ) + f irc-server-tab new-irc-tab ; + +: ( listener ui-window -- irc-tab ) + irc-tab new-irc-tab ; M: irc-tab pref-dim* drop { 480 480 } ; @@ -206,19 +218,25 @@ M: irc-tab pref-dim* : join-channel ( name ui-window -- ) [ dup ] dip [ swap ] keep - tabs>> add-page ; + add-page ; + +: query-nick ( nick ui-window -- ) + [ dup ] dip + [ swap ] keep + add-page ; : irc-window ( ui-window -- ) - [ tabs>> ] + [ ] [ client>> profile>> server>> ] bi open-window ; : ui-connect ( profile -- ui-window ) - ui-window new over >>client swap - [ connect-irc ] - [ [ ] dip add-listener ] - [ listeners>> +server-listener+ swap at over - "Server" associate >>tabs ] tri ; + + { [ [ ] dip add-listener ] + [ listeners>> +server-listener+ swap at dup + "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ] + [ >>client ] + [ connect-irc ] } cleave ; : server-open ( server port nick password channels -- ) [ ui-connect [ irc-window ] keep ] dip diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor index e6a2824433..5ef435a4e0 100644 --- a/extra/math/combinatorics/combinatorics-tests.factor +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -13,11 +13,6 @@ IN: math.combinatorics.tests [ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test [ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test -[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test -[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test -[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test -[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index f7d7b76fa4..6193edfb91 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting ; +namespaces sequences sequences.lib sorting ; IN: math.combinatorics permutation ; -: reorder ( seq indices -- seq ) - [ [ over nth , ] each drop ] { } make ; - PRIVATE> : factorial ( n -- n! ) @@ -42,7 +39,7 @@ PRIVATE> twiddle [ nPk ] keep factorial / ; : permutation ( n seq -- seq ) - tuck permutation-indices reorder ; + tuck permutation-indices nths ; : all-permutations ( seq -- seq ) [ diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt index 137b1605da..3be8a6d4d3 100644 --- a/extra/math/derivatives/authors.txt +++ b/extra/math/derivatives/authors.txt @@ -1 +1,2 @@ -Reginald Ford \ No newline at end of file +Reginald Ford +Eduardo Cavazos \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index 23847e82f7..15dd954b1c 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -1,9 +1,101 @@ -USING: help.markup help.syntax ; - +USING: help.markup help.syntax math.functions ; IN: math.derivatives HELP: derivative ( x function -- m ) -{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } } -{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ; +{ $values { "x" "a position on the function" } { "function" "a differentiable function" } } +{ $description + "Approximates the slope of the tangent line by using Ridders' " + "method of computing derivatives, from the chapter \"Accurate computation " + "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, Vol. 4, pp. 75-76 ." +} +{ $examples + { $example + "USING: math.derivatives prettyprint ;" + "[ sq ] 4 derivative ." + "8" + } + { $notes + "For applied scientists, you may play with the settings " + "in the source file to achieve arbitrary accuracy. " + } +} ; -{ derivative-func } related-words +HELP: (derivative) ( x function h err -- m ) +{ $values + { "x" "a position on the function" } + { "function" "a differentiable function" } + { + "h" "distance between the points of the first secant line used for " + "approximation of the tangent. This distance will be divided " + "constantly, by " { $link con } ". See " { $link init-hh } + " for the code which enforces this. H should be .001 to .5 -- too " + "small can cause bad convergence. Also, h should be small enough " + "to give the correct sgn(f'(x)). In other words, if you're expecting " + "a positive derivative, make h small enough to give the same " + "when plugged into the academic limit definition of a derivative. " + "See " { $link update-hh } " for the code which performs this task." + } + { + "err" "maximum tolerance of increase in error. For example, if this " + "is set to 2.0, the program will terminate with its nearest answer " + "when the error multiplies by 2. See " { $link check-safe } " for " + "the enforcing code." + } +} +{ $description + "Approximates the slope of the tangent line by using Ridders' " + "method of computing derivatives, from the chapter \"Accurate computation " + "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, " + "Vol. 4, pp. 75-76 ." +} +{ $examples + { $example + "USING: math.derivatives prettyprint ;" + "[ sq ] 4 derivative ." + "8" + } + { $notes + "For applied scientists, you may play with the settings " + "in the source file to achieve arbitrary accuracy. " + } +} ; + +HELP: derivative-func ( function -- der ) +{ $values { "func" "a differentiable function" } { "der" "the derivative" } } +{ $description + "Provides the derivative of the function. The implementation simply " + "attaches the " { $link derivative } " word to the end of the function." +} +{ $examples + { $example + "USING: math.derivatives prettyprint ;" + "60 deg>rad [ sin ] derivative-func call ." + "0.5000000000000173" + } + { $notes + "Without a heavy algebraic system, derivatives must be " + "approximated. With the current settings, there is a fair trade of " + "speed and accuracy; the first 12 digits " + "will always be correct with " { $link sin } " and " { $link cos } + ". The following code performs a minumum and maximum error test." + { $code + "USING: kernel math math.functions math.trig sequences sequences.lib ;" + "360" + "[" + " deg>rad" + " [ [ sin ] derivative-func call ]" + " ! Note: the derivative of sin is cos" + " [ cos ]" + " bi - abs" + "] map minmax" + + } + } +} ; + +ARTICLE: "derivatives" "The Derivative Toolkit" +"A toolkit for computing the derivative of functions." +{ $subsection derivative } +{ $subsection derivative-func } +{ $subsection (derivative) } ; +ABOUT: "derivatives" diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index d92066efaf..ad8d944bfe 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,10 +1,123 @@ -! Copyright © 2008 Reginald Keith Ford II -! Tool for computing the derivative of a function at a point -USING: kernel math math.points math.function-tools ; + +USING: kernel continuations combinators sequences math + math.order math.ranges accessors float-arrays ; + IN: math.derivatives -: small-amount ( -- n ) 1.0e-14 ; -: some-more ( x -- y ) small-amount + ; -: some-less ( x -- y ) small-amount - ; -: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ; -: derivative-func ( function -- function ) [ derivative ] curry ; \ No newline at end of file +TUPLE: state x func h err i j errt fac hh ans a done ; + +: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable +: ntab ( -- val ) 8 ; +: con ( -- val ) 1.6 ; +: con2 ( -- val ) con con * ; +: big ( -- val ) largest-float ; +: safe ( -- val ) 2.0 ; + +! Yes, this was ported from C code. +: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ; +: a[j][i] ( state -- elt ) [ i>> ] [ j>> ] [ a>> ] tri nth nth ; +: a[j-1][i] ( state -- elt ) [ i>> ] [ j>> 1 - ] [ a>> ] tri nth nth ; +: a[j-1][i-1] ( state -- elt ) [ i>> 1 - ] [ j>> 1 - ] [ a>> ] tri nth nth ; +: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ; + +: check-h ( state -- state ) + dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ; +: init-a ( state -- state ) ntab [ ntab ] replicate >>a ; +: init-hh ( state -- state ) dup h>> >>hh ; +: init-err ( state -- state ) big >>err ; +: update-hh ( state -- state ) dup hh>> con / >>hh ; +: reset-fac ( state -- state ) con2 >>fac ; +: update-fac ( state -- state ) dup fac>> con2 * >>fac ; + +! If error is decreased, save the improved answer +: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ; +: save-improved-answer ( state -- state ) + dup err>> >>errt + dup a[j][i] >>ans ; + +! If higher order is worse by a significant factor SAFE, then quit early. +: check-safe ( state -- state ) + dup + [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >= + [ t >>done ] + when ; +: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ; +: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ; +: limit-approx ( state -- val ) + [ + [ [ x+hh ] [ func>> ] bi call ] + [ [ x-hh ] [ func>> ] bi call ] + bi - + ] + [ hh>> 2.0 * ] + bi / ; +: a[0][0]! ( state -- state ) + { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; +: a[0][i]! ( state -- state ) + { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; +: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ; +: new-a[j][i] ( state -- val ) + [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ] + [ fac>> 1.0 - ] + bi / ; +: a[j][i]! ( state -- state ) + { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ; + +: update-errt ( state -- state ) + dup + [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ] + [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] + bi max + >>errt ; + +: not-done? ( state -- state ? ) dup done>> not ; + +: derive ( state -- state ) + init-a + check-h + init-hh + a[0][0]! + init-err + 1 ntab [a,b) + [ + >>i + not-done? + [ + update-hh + a[0][i]! + reset-fac + 1 over i>> [a,b] + [ + >>j + a[j][i]! + update-fac + update-errt + error-decreased? [ save-improved-answer ] when + ] + each + check-safe + ] + when + ] + each ; + +: derivative-state ( x func h err -- state ) + state new + swap >>err + swap >>h + swap >>func + swap >>x ; + +! For scientists: +! h should be .001 to .5 -- too small can cause bad convergence, +! h should be small enough to give the correct sgn(f'(x)) +! err is the max tolerance of gain in error for a single iteration- +: (derivative) ( x func h err -- ans error ) + derivative-state + derive + [ ans>> ] + [ errt>> ] + bi ; + +: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ; +: derivative-func ( func -- der ) [ derivative ] curry ; \ No newline at end of file diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 802bf9e14e..ec93a0891a 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -3,7 +3,7 @@ USING: kernel math arrays sequences sequences.lib ; IN: math.function-tools -: difference-func ( func func -- func ) [ bi - ] 2curry ; -: eval ( x func -- pt ) dupd call 2array ; -: eval-inverse ( y func -- pt ) dupd call swap 2array ; -: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; +: difference-func ( func func -- func ) [ bi - ] 2curry ; inline +: eval ( x func -- pt ) dupd call 2array ; inline +: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline +: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline diff --git a/extra/regexp2/authors.txt b/extra/regexp2/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/regexp2/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/regexp2/backend/backend.factor b/extra/regexp2/backend/backend.factor new file mode 100644 index 0000000000..5f59c25bc3 --- /dev/null +++ b/extra/regexp2/backend/backend.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors hashtables kernel math state-tables vars vectors ; +IN: regexp2.backend + +TUPLE: regexp + raw + { stack vector } + parse-tree + nfa-table + dfa-table + minimized-table + { state integer } + { new-states vector } + { visited-states hashtable } ; + +: reset-regexp ( regexp -- regexp ) + 0 >>state + V{ } clone >>stack + V{ } clone >>new-states + H{ } clone >>visited-states ; + +SYMBOL: current-regexp diff --git a/extra/regexp2/classes/classes.factor b/extra/regexp2/classes/classes.factor new file mode 100644 index 0000000000..0862f9cb63 --- /dev/null +++ b/extra/regexp2/classes/classes.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math math.order symbols regexp2.parser +words regexp2.utils unicode.categories combinators.short-circuit ; +IN: regexp2.classes + +GENERIC: class-member? ( obj class -- ? ) + +M: word class-member? ( obj class -- ? ) 2drop f ; +M: integer class-member? ( obj class -- ? ) 2drop f ; + +M: character-class-range class-member? ( obj class -- ? ) + [ from>> ] [ to>> ] bi between? ; + +M: any-char class-member? ( obj class -- ? ) + 2drop t ; + +M: letter-class class-member? ( obj class -- ? ) + drop letter? ; + +M: LETTER-class class-member? ( obj class -- ? ) + drop LETTER? ; + +M: ascii-class class-member? ( obj class -- ? ) + drop ascii? ; + +M: digit-class class-member? ( obj class -- ? ) + drop digit? ; + +M: alpha-class class-member? ( obj class -- ? ) + drop alpha? ; + +M: punctuation-class class-member? ( obj class -- ? ) + drop punct? ; + +M: java-printable-class class-member? ( obj class -- ? ) + drop java-printable? ; + +M: non-newline-blank-class class-member? ( obj class -- ? ) + drop { [ blank? ] [ CHAR: \n = not ] } 1&& ; + +M: control-character-class class-member? ( obj class -- ? ) + drop control-char? ; + +M: hex-digit-class class-member? ( obj class -- ? ) + drop hex-digit? ; + +M: java-blank-class class-member? ( obj class -- ? ) + drop java-blank? ; diff --git a/extra/regexp2/dfa/dfa.factor b/extra/regexp2/dfa/dfa.factor new file mode 100644 index 0000000000..0dcf6c4ab5 --- /dev/null +++ b/extra/regexp2/dfa/dfa.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators fry kernel locals +math math.order regexp2.nfa regexp2.transition-tables sequences +sets sorting vectors regexp2.utils sequences.lib ; +USING: io prettyprint threads ; +IN: regexp2.dfa + +: find-delta ( states transition regexp -- new-states ) + nfa-table>> transitions>> + rot [ swap at at ] with with map sift concat prune ; + +: (find-epsilon-closure) ( states regexp -- new-states ) + eps swap find-delta ; + +: find-epsilon-closure ( states regexp -- new-states ) + '[ dup , (find-epsilon-closure) union ] [ length ] while-changes + natural-sort ; + +: find-closure ( states transition regexp -- new-states ) + [ find-delta ] 2keep nip find-epsilon-closure ; + +: find-start-state ( regexp -- state ) + [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ; + +: find-transitions ( seq1 regexp -- seq2 ) + nfa-table>> transitions>> + [ at keys ] curry map concat eps swap remove ; + +: add-todo-state ( state regexp -- ) + 2dup visited-states>> key? [ + 2drop + ] [ + [ visited-states>> conjoin ] + [ new-states>> push ] 2bi + ] if ; + +: new-transitions ( regexp -- ) + dup new-states>> [ + drop + ] [ + dupd pop dup pick find-transitions rot + [ + [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep + >r swapd transition boa r> dfa-table>> add-transition + ] curry with each + new-transitions + ] if-empty ; + +: states ( hashtable -- array ) + [ keys ] + [ values [ values concat ] map concat append ] bi ; + +: set-final-states ( regexp -- ) + dup + [ nfa-table>> final-states>> keys ] + [ dfa-table>> transitions>> states ] bi + [ intersect empty? not ] with filter + + swap dfa-table>> final-states>> + [ conjoin ] curry each ; + +: set-initial-state ( regexp -- ) + dup + [ dfa-table>> ] [ find-start-state ] bi + [ >>start-state drop ] keep + 1vector >>new-states drop ; + +: construct-dfa ( regexp -- ) + [ set-initial-state ] [ new-transitions ] [ set-final-states ] tri ; diff --git a/extra/regexp2/nfa/nfa.factor b/extra/regexp2/nfa/nfa.factor new file mode 100644 index 0000000000..f87a2a7b52 --- /dev/null +++ b/extra/regexp2/nfa/nfa.factor @@ -0,0 +1,126 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs grouping kernel regexp2.backend +locals math namespaces regexp2.parser sequences state-tables fry +quotations math.order math.ranges vectors unicode.categories +regexp2.utils regexp2.transition-tables words sequences.lib ; +IN: regexp2.nfa + +SYMBOL: negation-mode +: negated? ( -- ? ) negation-mode get 0 or odd? ; + +SINGLETON: eps + +: next-state ( regexp -- state ) + [ state>> ] [ [ 1+ ] change-state drop ] bi ; + +: set-start-state ( regexp -- ) + dup stack>> [ + drop + ] [ + [ nfa-table>> ] [ pop first ] bi* >>start-state drop + ] if-empty ; + +GENERIC: nfa-node ( node -- ) + +:: add-simple-entry ( obj class -- ) + [let* | regexp [ current-regexp get ] + s0 [ regexp next-state ] + s1 [ regexp next-state ] + stack [ regexp stack>> ] + table [ regexp nfa-table>> ] | + negated? [ + s0 f obj class boa table add-transition + s0 s1 table add-transition + ] [ + s0 s1 obj class boa table add-transition + ] if + s0 s1 2array stack push + t s1 table final-states>> set-at ] ; + +:: concatenate-nodes ( -- ) + [let* | regexp [ current-regexp get ] + stack [ regexp stack>> ] + table [ regexp nfa-table>> ] + s2 [ stack peek first ] + s3 [ stack pop second ] + s0 [ stack peek first ] + s1 [ stack pop second ] | + s1 s2 eps table add-transition + s1 table final-states>> delete-at + s0 s3 2array stack push ] ; + +:: alternate-nodes ( -- ) + [let* | regexp [ current-regexp get ] + stack [ regexp stack>> ] + table [ regexp nfa-table>> ] + s2 [ stack peek first ] + s3 [ stack pop second ] + s0 [ stack peek first ] + s1 [ stack pop second ] + s4 [ regexp next-state ] + s5 [ regexp next-state ] | + s4 s0 eps table add-transition + s4 s2 eps table add-transition + s1 s5 eps table add-transition + s3 s5 eps table add-transition + s1 table final-states>> delete-at + s3 table final-states>> delete-at + t s5 table final-states>> set-at + s4 s5 2array stack push ] ; + +M: kleene-star nfa-node ( node -- ) + term>> nfa-node + [let* | regexp [ current-regexp get ] + stack [ regexp stack>> ] + s0 [ stack peek first ] + s1 [ stack pop second ] + s2 [ regexp next-state ] + s3 [ regexp next-state ] + table [ regexp nfa-table>> ] | + s1 table final-states>> delete-at + t s3 table final-states>> set-at + s1 s0 eps table add-transition + s2 s0 eps table add-transition + s2 s3 eps table add-transition + s1 s3 eps table add-transition + s2 s3 2array stack push ] ; + +M: concatenation nfa-node ( node -- ) + seq>> + [ [ nfa-node ] each ] + [ length 1- [ concatenate-nodes ] times ] bi ; + +M: alternation nfa-node ( node -- ) + seq>> + [ [ nfa-node ] each ] + [ length 1- [ alternate-nodes ] times ] bi ; + +M: constant nfa-node ( node -- ) + char>> literal-transition add-simple-entry ; + +M: epsilon nfa-node ( node -- ) + drop eps literal-transition add-simple-entry ; + +M: word nfa-node ( node -- ) + class-transition add-simple-entry ; + +M: character-class-range nfa-node ( node -- ) + class-transition add-simple-entry ; + +M: capture-group nfa-node ( node -- ) + term>> nfa-node ; + +M: negation nfa-node ( node -- ) + negation-mode inc + term>> nfa-node + negation-mode dec ; + +: construct-nfa ( regexp -- ) + [ + reset-regexp + negation-mode off + [ current-regexp set ] + [ parse-tree>> nfa-node ] + [ set-start-state ] tri + ] with-scope ; diff --git a/extra/regexp2/parser/parser-tests.factor b/extra/regexp2/parser/parser-tests.factor new file mode 100644 index 0000000000..9dc7dc7909 --- /dev/null +++ b/extra/regexp2/parser/parser-tests.factor @@ -0,0 +1,33 @@ +USING: kernel tools.test regexp2.backend regexp2 ; +IN: regexp2.parser + +: test-regexp ( string -- ) + default-regexp parse-regexp ; + +: test-regexp2 ( string -- regexp ) + default-regexp dup parse-regexp ; + +[ "(" ] [ unmatched-parentheses? ] must-fail-with + +[ ] [ "a|b" test-regexp ] unit-test +[ ] [ "a.b" test-regexp ] unit-test +[ ] [ "a|b|c" test-regexp ] unit-test +[ ] [ "abc|b" test-regexp ] unit-test +[ ] [ "a|bcd" test-regexp ] unit-test +[ ] [ "a|(b)" test-regexp ] unit-test +[ ] [ "(a)|b" test-regexp ] unit-test +[ ] [ "(a|b)" test-regexp ] unit-test +[ ] [ "((a)|(b))" test-regexp ] unit-test + +[ ] [ "(?:a)" test-regexp ] unit-test +[ ] [ "(?i:a)" test-regexp ] unit-test +[ ] [ "(?-i:a)" test-regexp ] unit-test +[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with +[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with + +[ ] [ "(?=a)" test-regexp ] unit-test + +[ ] [ "[abc]" test-regexp ] unit-test +[ ] [ "[a-c]" test-regexp ] unit-test +[ ] [ "[^a-c]" test-regexp ] unit-test +[ "[^]" test-regexp ] must-fail diff --git a/extra/regexp2/parser/parser.factor b/extra/regexp2/parser/parser.factor new file mode 100644 index 0000000000..fc1029db58 --- /dev/null +++ b/extra/regexp2/parser/parser.factor @@ -0,0 +1,362 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators io io.streams.string +kernel math math.parser multi-methods namespaces qualified +quotations sequences sequences.lib splitting symbols vectors +dlists math.order combinators.lib unicode.categories +sequences.lib regexp2.backend regexp2.utils ; +IN: regexp2.parser + +FROM: math.ranges => [a,b] ; + +MIXIN: node +TUPLE: concatenation seq ; INSTANCE: concatenation node +TUPLE: alternation seq ; INSTANCE: alternation node +TUPLE: kleene-star term ; INSTANCE: kleene-star node +TUPLE: question term ; INSTANCE: question node +TUPLE: negation term ; INSTANCE: negation node +TUPLE: constant char ; INSTANCE: constant node +TUPLE: range from to ; INSTANCE: range node +TUPLE: lookahead term ; INSTANCE: lookahead node +TUPLE: lookbehind term ; INSTANCE: lookbehind node +TUPLE: capture-group term ; INSTANCE: capture-group node +TUPLE: non-capture-group term ; INSTANCE: non-capture-group node +TUPLE: independent-group term ; INSTANCE: independent-group node +TUPLE: character-class-range from to ; INSTANCE: character-class-range node +SINGLETON: epsilon INSTANCE: epsilon node +SINGLETON: any-char INSTANCE: any-char node +SINGLETON: front-anchor INSTANCE: front-anchor node +SINGLETON: back-anchor INSTANCE: back-anchor node + +TUPLE: option-on option ; INSTANCE: option-on node +TUPLE: option-off option ; INSTANCE: option-off node +SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case ; +MIXIN: regexp-option +INSTANCE: unix-lines regexp-option +INSTANCE: dotall regexp-option +INSTANCE: multiline regexp-option +INSTANCE: comments regexp-option +INSTANCE: case-insensitive regexp-option +INSTANCE: unicode-case regexp-option + +SINGLETONS: letter-class LETTER-class Letter-class digit-class +alpha-class non-newline-blank-class +ascii-class punctuation-class java-printable-class blank-class +control-character-class hex-digit-class java-blank-class c-identifier-class ; + +SINGLETONS: beginning-of-group end-of-group +beginning-of-character-class end-of-character-class +left-parenthesis pipe caret dash ; + +: ( obj -- constant ) constant boa ; +: ( obj -- negation ) negation boa ; +: ( seq -- concatenation ) >vector concatenation boa ; +: ( seq -- alternation ) >vector alternation boa ; +: ( obj -- capture-group ) capture-group boa ; +: ( obj -- kleene-star ) kleene-star boa ; + +: first|concatenation ( seq -- first/concatenation ) + dup length 1 = [ first ] [ ] if ; + +: first|alternation ( seq -- first/alternation ) + dup length 1 = [ first ] [ ] if ; + +ERROR: unmatched-parentheses ; + +: make-positive-lookahead ( string -- ) + lookahead boa push-stack ; + +: make-negative-lookahead ( string -- ) + lookahead boa push-stack ; + +: make-independent-group ( string -- ) + #! no backtracking + independent-group boa push-stack ; + +: make-positive-lookbehind ( string -- ) + lookbehind boa push-stack ; + +: make-negative-lookbehind ( string -- ) + lookbehind boa push-stack ; + +DEFER: nested-parse-regexp +: make-non-capturing-group ( string -- ) + non-capture-group boa push-stack ; + +ERROR: bad-option ch ; + +: option ( ch -- singleton ) + { + { CHAR: i [ case-insensitive ] } + { CHAR: d [ unix-lines ] } + { CHAR: m [ multiline ] } + { CHAR: s [ dotall ] } + { CHAR: u [ unicode-case ] } + { CHAR: x [ comments ] } + [ bad-option ] + } case ; + +: option-on ( ch -- ) option \ option-on boa push-stack ; +: option-off ( ch -- ) option \ option-off boa push-stack ; +: toggle-option ( ch ? -- ) [ option-on ] [ option-off ] if ; +: (parse-options) ( string ? -- ) [ toggle-option ] curry each ; + +: parse-options ( string -- ) + "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ; + +DEFER: (parse-regexp) +: parse-special-group-options ( options -- ) + beginning-of-group push-stack + parse-options (parse-regexp) pop-stack make-non-capturing-group ; + +ERROR: bad-special-group string ; + +: (parse-special-group) ( -- ) + read1 { + { [ dup CHAR: : = ] + [ drop nested-parse-regexp pop-stack make-non-capturing-group ] } + { [ dup CHAR: = = ] + [ drop nested-parse-regexp pop-stack make-positive-lookahead ] } + { [ dup CHAR: = = ] + [ drop nested-parse-regexp pop-stack make-negative-lookahead ] } + { [ dup CHAR: > = ] + [ drop nested-parse-regexp pop-stack make-independent-group ] } + { [ dup CHAR: < = peek1 CHAR: = = and ] + [ drop read1 drop nested-parse-regexp pop-stack make-positive-lookbehind ] } + { [ dup CHAR: < = peek1 CHAR: ! = and ] + [ drop read1 drop nested-parse-regexp pop-stack make-negative-lookbehind ] } + [ + ":" read-until [ bad-special-group ] unless + swap prefix parse-special-group-options + ] + } cond ; + +: handle-left-parenthesis ( -- ) + peek1 CHAR: ? = + [ read1 drop (parse-special-group) ] + [ nested-parse-regexp ] if ; + +: handle-dot ( -- ) any-char push-stack ; +: handle-pipe ( -- ) pipe push-stack ; +: handle-star ( -- ) stack pop push-stack ; +: handle-question ( -- ) + stack pop epsilon 2array push-stack ; +: handle-plus ( -- ) + stack pop dup 2array push-stack ; + +ERROR: unmatched-brace ; +: parse-repetition ( -- start finish ? ) + "}" read-until [ unmatched-brace ] unless + [ "," split1 [ string>number ] bi@ ] + [ CHAR: , swap index >boolean ] bi ; + +: replicate/concatenate ( n obj -- obj' ) + over zero? [ 2drop epsilon ] + [ first|concatenation ] if ; + +: exactly-n ( n -- ) + stack pop replicate/concatenate push-stack ; + +: at-least-n ( n -- ) + stack pop + [ replicate/concatenate ] keep + 2array push-stack ; + +: at-most-n ( n -- ) + 1+ + stack pop + [ replicate/concatenate ] curry map push-stack ; + +: from-m-to-n ( m n -- ) + [a,b] + stack pop + [ replicate/concatenate ] curry map + push-stack ; + +ERROR: invalid-range a b ; + +: handle-left-brace ( -- ) + parse-repetition + >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r> + [ + 2dup and [ from-m-to-n ] + [ [ nip at-most-n ] [ at-least-n ] if* ] if + ] [ drop 0 max exactly-n ] if ; + +: handle-front-anchor ( -- ) front-anchor push-stack ; +: handle-back-anchor ( -- ) back-anchor push-stack ; + +ERROR: bad-character-class obj ; +ERROR: expected-posix-class ; + +: parse-posix-class ( -- obj ) + read1 CHAR: { = [ expected-posix-class ] unless + "}" read-until [ bad-character-class ] unless + { + { "Lower" [ letter-class ] } + { "Upper" [ LETTER-class ] } + { "ASCII" [ ascii-class ] } + { "Alpha" [ Letter-class ] } + { "Digit" [ digit-class ] } + { "Alnum" [ alpha-class ] } + { "Punct" [ punctuation-class ] } + { "Graph" [ java-printable-class ] } + { "Print" [ java-printable-class ] } + { "Blank" [ non-newline-blank-class ] } + { "Cntrl" [ control-character-class ] } + { "XDigit" [ hex-digit-class ] } + { "Space" [ java-blank-class ] } + ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss + [ bad-character-class ] + } case ; + +: parse-octal ( -- n ) 3 read oct> check-octal ; +: parse-short-hex ( -- n ) 2 read hex> check-hex ; +: parse-long-hex ( -- n ) 6 read hex> check-hex ; +: parse-control-character ( -- n ) read1 ; + +ERROR: bad-escaped-literals seq ; +: parse-escaped-literals ( -- obj ) + "\\E" read-until [ bad-escaped-literals ] unless + read1 drop + [ epsilon ] [ + [ ] V{ } map-as + first|concatenation + ] if-empty ; + +: parse-escaped ( -- obj ) + read1 + { + { CHAR: \ [ CHAR: \ ] } + { CHAR: . [ CHAR: . ] } + { CHAR: t [ CHAR: \t ] } + { CHAR: n [ CHAR: \n ] } + { CHAR: r [ CHAR: \r ] } + { CHAR: f [ HEX: c ] } + { CHAR: a [ HEX: 7 ] } + { CHAR: e [ HEX: 1b ] } + + { CHAR: d [ digit-class ] } + { CHAR: D [ digit-class ] } + { CHAR: s [ java-blank-class ] } + { CHAR: S [ java-blank-class ] } + { CHAR: w [ c-identifier-class ] } + { CHAR: W [ c-identifier-class ] } + + { CHAR: p [ parse-posix-class ] } + { CHAR: P [ parse-posix-class ] } + { CHAR: x [ parse-short-hex ] } + { CHAR: u [ parse-long-hex ] } + { CHAR: 0 [ parse-octal ] } + { CHAR: c [ parse-control-character ] } + + { CHAR: Q [ parse-escaped-literals ] } + } case ; + +: handle-escape ( -- ) parse-escaped push-stack ; + +: handle-dash ( vector -- vector' ) + H{ { dash CHAR: - } } substitute ; + +: character-class>alternation ( seq -- alternation ) + [ dup number? [ ] when ] map first|alternation ; + +: handle-caret ( vector -- vector' ) + dup [ length 2 >= ] [ first caret eq? ] bi and [ + rest-slice character-class>alternation + ] [ + character-class>alternation + ] if ; + +: make-character-class ( -- character-class ) + [ beginning-of-character-class swap cut-stack ] change-whole-stack + handle-dash handle-caret ; + +: apply-dash ( -- ) + stack [ pop3 nip character-class-range boa ] keep push ; + +: apply-dash? ( -- ? ) + stack dup length 3 >= + [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ; + +ERROR: empty-negated-character-class ; +DEFER: handle-left-bracket +: (parse-character-class) ( -- ) + read1 [ empty-negated-character-class ] unless* { + { CHAR: [ [ handle-left-bracket t ] } + { CHAR: ] [ make-character-class push-stack f ] } + { CHAR: - [ dash push-stack t ] } + { CHAR: \ [ parse-escaped push-stack t ] } + [ push-stack apply-dash? [ apply-dash ] when t ] + } case + [ (parse-character-class) ] when ; + +: parse-character-class-second ( -- ) + read1 { + { CHAR: [ [ CHAR: [ push-stack ] } + { CHAR: ] [ CHAR: ] push-stack ] } + { CHAR: - [ CHAR: - push-stack ] } + [ push1 ] + } case ; + +: parse-character-class-first ( -- ) + read1 { + { CHAR: ^ [ caret push-stack parse-character-class-second ] } + { CHAR: [ [ CHAR: [ push-stack ] } + { CHAR: ] [ CHAR: ] push-stack ] } + { CHAR: - [ CHAR: - push-stack ] } + [ push1 ] + } case ; + +: handle-left-bracket ( -- ) + beginning-of-character-class push-stack + parse-character-class-first (parse-character-class) ; + +ERROR: empty-regexp ; +: finish-regexp-parse ( stack -- obj ) + dup length { + { 0 [ empty-regexp ] } + { 1 [ first ] } + [ + drop { pipe } split + [ first|concatenation ] map first|alternation + ] + } case ; + +: handle-right-parenthesis ( -- ) + stack beginning-of-group over last-index cut rest + [ current-regexp get swap >>stack drop ] + [ finish-regexp-parse push-stack ] bi* ; + +: nested-parse-regexp ( -- ) + beginning-of-group push-stack (parse-regexp) ; + +: ((parse-regexp)) ( token -- ) + { + { CHAR: . [ handle-dot ] } + { CHAR: ( [ handle-left-parenthesis ] } + { CHAR: ) [ handle-right-parenthesis ] } + { CHAR: | [ handle-pipe ] } + { CHAR: ? [ handle-question ] } + { CHAR: * [ handle-star ] } + { CHAR: + [ handle-plus ] } + { CHAR: { [ handle-left-brace ] } + { CHAR: [ [ handle-left-bracket ] } + { CHAR: ^ [ handle-front-anchor ] } + { CHAR: $ [ handle-back-anchor ] } + { CHAR: \ [ handle-escape ] } + [ push-stack ] + } case ; + +: (parse-regexp) ( -- ) + read1 [ ((parse-regexp)) (parse-regexp) ] when* ; + +: parse-regexp ( regexp -- ) + dup current-regexp [ + raw>> [ + [ (parse-regexp) ] with-input-stream + ] unless-empty + current-regexp get + stack finish-regexp-parse + >>parse-tree drop + ] with-variable ; diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..2b34fe6e77 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,240 @@ +USING: regexp2 tools.test kernel regexp2.traversal ; +IN: regexp2-tests + +[ f ] [ "b" "a*" matches? ] unit-test +[ t ] [ "" "a*" matches? ] unit-test +[ t ] [ "a" "a*" matches? ] unit-test +[ t ] [ "aaaaaaa" "a*" matches? ] unit-test +[ f ] [ "ab" "a*" matches? ] unit-test + +[ t ] [ "abc" "abc" matches? ] unit-test +[ t ] [ "a" "a|b|c" matches? ] unit-test +[ t ] [ "b" "a|b|c" matches? ] unit-test +[ t ] [ "c" "a|b|c" matches? ] unit-test +[ f ] [ "c" "d|e|f" matches? ] unit-test + +[ f ] [ "aa" "a|b|c" matches? ] unit-test +[ f ] [ "bb" "a|b|c" matches? ] unit-test +[ f ] [ "cc" "a|b|c" matches? ] unit-test +[ f ] [ "cc" "d|e|f" matches? ] unit-test + +[ f ] [ "" "a+" matches? ] unit-test +[ t ] [ "a" "a+" matches? ] unit-test +[ t ] [ "aa" "a+" matches? ] unit-test + +[ t ] [ "" "a?" matches? ] unit-test +[ t ] [ "a" "a?" matches? ] unit-test +[ f ] [ "aa" "a?" matches? ] unit-test + +[ f ] [ "" "." matches? ] unit-test +[ t ] [ "a" "." matches? ] unit-test +[ t ] [ "." "." matches? ] unit-test +! [ f ] [ "\n" "." matches? ] unit-test + +[ f ] [ "" ".+" matches? ] unit-test +[ t ] [ "a" ".+" matches? ] unit-test +[ t ] [ "ab" ".+" matches? ] unit-test + + +[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test +[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test +[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test +[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test +[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test +[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test + +[ t ] [ "foo" "foo|bar" matches? ] unit-test +[ t ] [ "bar" "foo|bar" matches? ] unit-test +[ f ] [ "foobar" "foo|bar" matches? ] unit-test + +[ f ] [ "" "(a)" matches? ] unit-test +[ t ] [ "a" "(a)" matches? ] unit-test +[ f ] [ "aa" "(a)" matches? ] unit-test +[ t ] [ "aa" "(a*)" matches? ] unit-test + +[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test +[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test + +[ f ] [ "" "a{1}" matches? ] unit-test +[ t ] [ "a" "a{1}" matches? ] unit-test +[ f ] [ "aa" "a{1}" matches? ] unit-test + +[ f ] [ "a" "a{2,}" matches? ] unit-test +[ t ] [ "aaa" "a{2,}" matches? ] unit-test +[ t ] [ "aaaa" "a{2,}" matches? ] unit-test +[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test + +[ t ] [ "" "a{,2}" matches? ] unit-test +[ t ] [ "a" "a{,2}" matches? ] unit-test +[ t ] [ "aa" "a{,2}" matches? ] unit-test +[ f ] [ "aaa" "a{,2}" matches? ] unit-test +[ f ] [ "aaaa" "a{,2}" matches? ] unit-test +[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test + +[ f ] [ "" "a{1,3}" matches? ] unit-test +[ t ] [ "a" "a{1,3}" matches? ] unit-test +[ t ] [ "aa" "a{1,3}" matches? ] unit-test +[ t ] [ "aaa" "a{1,3}" matches? ] unit-test +[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test + +[ f ] [ "" "[a]" matches? ] unit-test +[ t ] [ "a" "[a]" matches? ] unit-test +[ t ] [ "a" "[abc]" matches? ] unit-test +[ f ] [ "b" "[a]" matches? ] unit-test +[ f ] [ "d" "[abc]" matches? ] unit-test +[ t ] [ "ab" "[abc]{1,2}" matches? ] unit-test +[ f ] [ "abc" "[abc]{1,2}" matches? ] unit-test + +[ f ] [ "" "[^a]" matches? ] unit-test +[ f ] [ "a" "[^a]" matches? ] unit-test +[ f ] [ "a" "[^abc]" matches? ] unit-test +[ t ] [ "b" "[^a]" matches? ] unit-test +[ t ] [ "d" "[^abc]" matches? ] unit-test +[ f ] [ "ab" "[^abc]{1,2}" matches? ] unit-test +[ f ] [ "abc" "[^abc]{1,2}" matches? ] unit-test + +[ t ] [ "]" "[]]" matches? ] unit-test +[ f ] [ "]" "[^]]" matches? ] unit-test +[ t ] [ "a" "[^]]" matches? ] unit-test + +[ "^" "[^]" matches? ] must-fail +[ t ] [ "^" "[]^]" matches? ] unit-test +[ t ] [ "]" "[]^]" matches? ] unit-test + +[ t ] [ "[" "[[]" matches? ] unit-test +[ f ] [ "^" "[^^]" matches? ] unit-test +[ t ] [ "a" "[^^]" matches? ] unit-test + +[ t ] [ "-" "[-]" matches? ] unit-test +[ f ] [ "a" "[-]" matches? ] unit-test +[ f ] [ "-" "[^-]" matches? ] unit-test +[ t ] [ "a" "[^-]" matches? ] unit-test + +[ t ] [ "-" "[-a]" matches? ] unit-test +[ t ] [ "a" "[-a]" matches? ] unit-test +[ t ] [ "-" "[a-]" matches? ] unit-test +[ t ] [ "a" "[a-]" matches? ] unit-test +[ f ] [ "b" "[a-]" matches? ] unit-test +[ f ] [ "-" "[^-]" matches? ] unit-test +[ t ] [ "a" "[^-]" matches? ] unit-test + +[ f ] [ "-" "[a-c]" matches? ] unit-test +[ t ] [ "-" "[^a-c]" matches? ] unit-test +[ t ] [ "b" "[a-c]" matches? ] unit-test +[ f ] [ "b" "[^a-c]" matches? ] unit-test + +[ t ] [ "-" "[a-c-]" matches? ] unit-test +[ f ] [ "-" "[^a-c-]" matches? ] unit-test + +[ t ] [ "\\" "[\\\\]" matches? ] unit-test +[ f ] [ "a" "[\\\\]" matches? ] unit-test +[ f ] [ "\\" "[^\\\\]" matches? ] unit-test +[ t ] [ "a" "[^\\\\]" matches? ] unit-test + +[ t ] [ "0" "[\\d]" matches? ] unit-test +[ f ] [ "a" "[\\d]" matches? ] unit-test +[ f ] [ "0" "[^\\d]" matches? ] unit-test +[ t ] [ "a" "[^\\d]" matches? ] unit-test + +[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" matches? ] unit-test +[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" matches? ] unit-test +[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" matches? ] unit-test + +[ t ] [ "1000" "\\d{4,6}" matches? ] unit-test +[ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test + +[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test +[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test +[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test +[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test +! +[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test +[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test + +[ t ] [ "" "\\Q\\E" matches? ] unit-test +[ f ] [ "a" "\\Q\\E" matches? ] unit-test +[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test +[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test +[ t ] [ "s" "\\Qs\\E" matches? ] unit-test + +[ t ] [ "S" "\\0123" matches? ] unit-test +[ t ] [ "SXY" "\\0123XY" matches? ] unit-test +[ t ] [ "x" "\\x78" matches? ] unit-test +[ f ] [ "y" "\\x78" matches? ] unit-test +[ t ] [ "x" "\\u000078" matches? ] unit-test +[ f ] [ "y" "\\u000078" matches? ] unit-test + +[ t ] [ "ab" "a+b" matches? ] unit-test +[ f ] [ "b" "a+b" matches? ] unit-test +[ t ] [ "aab" "a+b" matches? ] unit-test +[ f ] [ "abb" "a+b" matches? ] unit-test + +[ t ] [ "abbbb" "ab*" matches? ] unit-test +[ t ] [ "a" "ab*" matches? ] unit-test +[ f ] [ "abab" "ab*" matches? ] unit-test + +[ f ] [ "x" "\\." matches? ] unit-test +[ t ] [ "." "\\." matches? ] unit-test + +[ t ] [ "aaaab" "a+ab" matches? ] unit-test +[ f ] [ "aaaxb" "a+ab" matches? ] unit-test +[ t ] [ "aaacb" "a+cb" matches? ] unit-test +[ f ] [ "aaaab" "a++ab" matches? ] unit-test +[ t ] [ "aaacb" "a++cb" matches? ] unit-test + +[ 3 ] [ "aaacb" "a*" match-head ] unit-test +[ 1 ] [ "aaacb" "a+?" match-head ] unit-test +[ 2 ] [ "aaacb" "aa?" match-head ] unit-test +[ 1 ] [ "aaacb" "aa??" match-head ] unit-test +[ 3 ] [ "aacb" "aa?c" match-head ] unit-test +[ 3 ] [ "aacb" "aa??c" match-head ] unit-test + +! [ t ] [ "aaa" "AAA" t matches? ] unit-test +! [ f ] [ "aax" "AAA" t matches? ] unit-test +! [ t ] [ "aaa" "A*" t matches? ] unit-test +! [ f ] [ "aaba" "A*" t matches? ] unit-test +! [ t ] [ "b" "[AB]" t matches? ] unit-test +! [ f ] [ "c" "[AB]" t matches? ] unit-test +! [ t ] [ "c" "[A-Z]" t matches? ] unit-test +! [ f ] [ "3" "[A-Z]" t matches? ] unit-test + +[ ] [ + "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))" + drop +] unit-test + +[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +[ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test + +! [ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test +! [ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test + +! [ f ] [ "foobxr" "foo\\z" match-head ] unit-test +! [ 3 ] [ "foo" "foo\\z" match-head ] unit-test + +! [ 3 ] [ "foo bar" "foo\\b" match-head ] unit-test +! [ f ] [ "fooxbar" "foo\\b" matches? ] unit-test +! [ t ] [ "foo" "foo\\b" matches? ] unit-test +! [ t ] [ "foo bar" "foo\\b bar" matches? ] unit-test +! [ f ] [ "fooxbar" "foo\\bxbar" matches? ] unit-test +! [ f ] [ "foo" "foo\\bbar" matches? ] unit-test + +! [ f ] [ "foo bar" "foo\\B" matches? ] unit-test +! [ 3 ] [ "fooxbar" "foo\\B" match-head ] unit-test +! [ t ] [ "foo" "foo\\B" matches? ] unit-test +! [ f ] [ "foo bar" "foo\\B bar" matches? ] unit-test +! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test +! [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test + +! [ t ] [ "s@f" "[a-z.-]@[a-z]" matches? ] unit-test +! [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test +! [ t ] [ ".o" "\\.[a-z]" matches? ] unit-test + +! Bug in parsing word +! [ t ] [ "a" R' a' matches? ] unit-test + +! ((A)(B(C))) +! 1. ((A)(B(C))) +! 2. (A) +! 3. (B(C)) +! 4. (C) diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..0f15b3c1ec --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel regexp2.backend regexp2.utils +regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal state-tables +regexp2.transition-tables ; +IN: regexp2 + +: default-regexp ( string -- regexp ) + regexp new + swap >>raw + >>nfa-table + >>dfa-table + >>minimized-table + reset-regexp ; + +: ( string -- regexp ) + default-regexp + { + [ parse-regexp ] + [ construct-nfa ] + [ construct-dfa ] + [ ] + } cleave ; + +: R! CHAR: ! ; parsing +: R" CHAR: " ; parsing +: R# CHAR: # ; parsing +: R' CHAR: ' ; parsing +: R( CHAR: ) ; parsing +: R/ CHAR: / ; parsing +: R@ CHAR: @ ; parsing +: R[ CHAR: ] ; parsing +: R` CHAR: ` ; parsing +: R{ CHAR: } ; parsing +: R| CHAR: | ; parsing diff --git a/extra/regexp2/summary.txt b/extra/regexp2/summary.txt new file mode 100644 index 0000000000..aa1e1c27a9 --- /dev/null +++ b/extra/regexp2/summary.txt @@ -0,0 +1 @@ +Regular expressions diff --git a/extra/regexp2/tags.txt b/extra/regexp2/tags.txt new file mode 100644 index 0000000000..65bc471f6b --- /dev/null +++ b/extra/regexp2/tags.txt @@ -0,0 +1,2 @@ +parsing +text diff --git a/extra/regexp2/transition-tables/transition-tables.factor b/extra/regexp2/transition-tables/transition-tables.factor new file mode 100644 index 0000000000..0547846655 --- /dev/null +++ b/extra/regexp2/transition-tables/transition-tables.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs fry hashtables kernel sequences +vectors ; +IN: regexp2.transition-tables + +: insert-at ( value key hash -- ) + 2dup at* [ + 2nip push + ] [ + drop >r >r dup vector? [ 1vector ] unless r> r> set-at + ] if ; + +: ?insert-at ( value key hash/f -- hash ) + [ H{ } clone ] unless* [ insert-at ] keep ; + +TUPLE: transition from to obj ; +TUPLE: literal-transition < transition ; +TUPLE: class-transition < transition ; +TUPLE: default-transition < transition ; + +TUPLE: literal obj ; +TUPLE: class obj ; +TUPLE: default ; +: ( from to obj -- transition ) literal-transition boa ; +: ( from to obj -- transition ) class-transition boa ; +: ( from to -- transition ) t default-transition boa ; + +TUPLE: transition-table transitions + literals classes defaults + start-state final-states ; + +: ( -- transition-table ) + transition-table new + H{ } clone >>transitions + H{ } clone >>final-states ; + +: set-transition ( transition hash -- ) + >r [ to>> ] [ obj>> ] [ from>> ] tri r> + 2dup at* [ 2nip insert-at ] + [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ; + +: add-transition ( transition transition-table -- ) + transitions>> set-transition ; diff --git a/extra/regexp2/traversal/traversal.factor b/extra/regexp2/traversal/traversal.factor new file mode 100644 index 0000000000..2fbdc49a2a --- /dev/null +++ b/extra/regexp2/traversal/traversal.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.lib kernel +math math.ranges quotations sequences regexp2.parser +regexp2.classes combinators.short-circuit assocs.lib +sequences.lib ; +IN: regexp2.traversal + +TUPLE: dfa-traverser + dfa-table + last-state current-state + text + start-index current-index + matches ; + +: ( text regexp -- match ) + dfa-table>> + dfa-traverser new + swap [ start-state>> >>current-state ] keep + >>dfa-table + swap >>text + 0 >>start-index + 0 >>current-index + V{ } clone >>matches ; + +: final-state? ( dfa-traverser -- ? ) + [ current-state>> ] [ dfa-table>> final-states>> ] bi + key? ; + +: text-finished? ( dfa-traverser -- ? ) + [ current-index>> ] [ text>> length ] bi >= ; + +: save-final-state ( dfa-straverser -- ) + [ current-index>> ] [ matches>> ] bi push ; + +: match-done? ( dfa-traverser -- ? ) + dup final-state? [ + dup save-final-state + ] when text-finished? ; + +: increment-state ( dfa-traverser state -- dfa-traverser ) + >r [ 1+ ] change-current-index + dup current-state>> >>last-state r> + first >>current-state ; + +: match-failed ( dfa-traverser -- dfa-traverser ) + V{ } clone >>matches ; + +: match-literal ( transition from-state table -- to-state/f ) + transitions>> [ at ] [ 2drop f ] if-at ; + +: assoc-with ( param assoc quot -- assoc curry ) + swapd [ [ -rot ] dip call ] 2curry ; inline + +: match-class ( transition from-state table -- to-state/f ) + transitions>> at* [ + [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if + ] [ drop ] if ; + +: match-default ( transition from-state table -- to-state/f ) + [ nip ] dip transitions>> + [ t swap [ drop f ] unless-at ] [ drop f ] if-at ; + +: match-transition ( obj from-state dfa -- to-state/f ) + { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; + +: setup-match ( match -- obj state dfa-table ) + { current-index>> text>> current-state>> dfa-table>> } get-slots + [ nth ] 2dip ; + +: do-match ( dfa-traverser -- dfa-traverser ) + dup match-done? [ + dup setup-match match-transition + [ increment-state do-match ] when* + ] unless ; + +: return-match ( dfa-traverser -- interval/f ) + dup matches>> + [ drop f ] + [ [ start-index>> ] [ peek ] bi* 1 ] if-empty ; + +: match ( string regexp -- pair ) + do-match return-match ; + +: matches? ( string regexp -- ? ) + dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ; + +: match-head ( string regexp -- end ) match length>> 1- ; diff --git a/extra/regexp2/utils/utils.factor b/extra/regexp2/utils/utils.factor new file mode 100644 index 0000000000..0167e73005 --- /dev/null +++ b/extra/regexp2/utils/utils.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators.lib io kernel +math math.order namespaces regexp2.backend sequences +sequences.lib unicode.categories math.ranges fry +combinators.short-circuit ; +IN: regexp2.utils + +: (while-changes) ( obj quot pred pred-ret -- obj ) + ! quot: ( obj -- obj' ) + ! pred: ( obj -- <=> ) + >r >r dup slip r> pick over call r> dupd = + [ 3drop ] [ (while-changes) ] if ; inline + +: while-changes ( obj quot pred -- obj' ) + pick over call (while-changes) ; inline + +: last-state ( regexp -- range ) stack>> peek first2 [a,b] ; +: push1 ( obj -- ) input-stream get stream>> push ; +: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ; +: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ; + +: stack ( -- obj ) current-regexp get stack>> ; +: change-whole-stack ( quot -- ) + current-regexp get + [ stack>> swap call ] keep (>>stack) ; inline +: push-stack ( obj -- ) stack push ; +: pop-stack ( -- obj ) stack pop ; +: cut-out ( vector n -- vector' vector ) cut rest ; +ERROR: cut-stack-error ; +: cut-stack ( obj vector -- vector' vector ) + tuck last-index [ cut-stack-error ] unless* cut-out swap ; + +ERROR: bad-octal number ; +ERROR: bad-hex number ; +: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ; +: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ; + +: ascii? ( n -- ? ) 0 HEX: 7f between? ; +: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ; +: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ; + +: hex-digit? ( n -- ? ) + [ + [ decimal-digit? ] + [ CHAR: a CHAR: f between? ] + [ CHAR: A CHAR: F between? ] + ] 1|| ; + +: control-char? ( n -- ? ) + [ + [ 0 HEX: 1f between? ] + [ HEX: 7f = ] + ] 1|| ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + [ [ alpha? ] [ CHAR: _ = ] ] 1|| ; + +: java-blank? ( n -- ? ) + { + CHAR: \s CHAR: \t CHAR: \n + HEX: b HEX: 7 CHAR: \r + } member? ; + +: java-printable? ( n -- ? ) + [ [ alpha? ] [ punct? ] ] 1|| ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1167a3b7b4..17f855c264 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -211,8 +211,11 @@ PRIVATE> : insert-nth ( elt n seq -- seq' ) swap cut-slice [ swap 1array ] dip 3append ; -: if-seq ( seq quot1 quot2 -- ) - [ f like ] 2dip if* ; inline +: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline + +: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline + +: when-empty ( seq quot1 -- ) [ ] if-empty ; inline + +: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline -: if-empty ( seq quot1 quot2 -- ) - swap if-seq ; inline diff --git a/extra/serial/authors.txt b/extra/serial/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/serial/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/serial/serial.factor b/extra/serial/serial.factor new file mode 100644 index 0000000000..39a63927da --- /dev/null +++ b/extra/serial/serial.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types assocs combinators destructors +kernel math math.bitfields math.parser sequences summary system +vocabs.loader ; +IN: serial + +TUPLE: serial stream path baud + termios iflag oflag cflag lflag ; + +ERROR: invalid-baud baud ; +M: invalid-baud summary ( invalid-baud -- string ) + "Baud rate " + swap baud>> number>string + " not supported" 3append ; + +HOOK: lookup-baud os ( m -- n ) +HOOK: open-serial os ( serial -- serial' ) +M: serial dispose ( serial -- ) stream>> dispose ; + +{ + { [ os unix? ] [ "serial.unix" ] } +} cond require diff --git a/extra/serial/summary.txt b/extra/serial/summary.txt new file mode 100644 index 0000000000..5ccd99dbaa --- /dev/null +++ b/extra/serial/summary.txt @@ -0,0 +1 @@ +Serial port library diff --git a/extra/serial/tags.txt b/extra/serial/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor new file mode 100644 index 0000000000..feed85348b --- /dev/null +++ b/extra/serial/unix/bsd/bsd.factor @@ -0,0 +1,86 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel math.bitfields sequences system serial ; +IN: serial.unix + +M: bsd lookup-baud ( m -- n ) + dup { + 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 + 7200 9600 14400 19200 28800 38400 57600 76800 115200 + 230400 460800 921600 + } member? [ invalid-baud ] unless ; + +: TCSANOW 0 ; inline +: TCSADRAIN 1 ; inline +: TCSAFLUSH 2 ; inline +: TCSASOFT HEX: 10 ; inline + +: TCIFLUSH 1 ; inline +: TCOFLUSH 2 ; inline +: TCIOFLUSH 3 ; inline +: TCOOFF 1 ; inline +: TCOON 2 ; inline +: TCIOFF 3 ; inline +: TCION 4 ; inline + +! iflags +: IGNBRK HEX: 00000001 ; inline +: BRKINT HEX: 00000002 ; inline +: IGNPAR HEX: 00000004 ; inline +: PARMRK HEX: 00000008 ; inline +: INPCK HEX: 00000010 ; inline +: ISTRIP HEX: 00000020 ; inline +: INLCR HEX: 00000040 ; inline +: IGNCR HEX: 00000080 ; inline +: ICRNL HEX: 00000100 ; inline +: IXON HEX: 00000200 ; inline +: IXOFF HEX: 00000400 ; inline +: IXANY HEX: 00000800 ; inline +: IMAXBEL HEX: 00002000 ; inline +: IUTF8 HEX: 00004000 ; inline + +! oflags +: OPOST HEX: 00000001 ; inline +: ONLCR HEX: 00000002 ; inline +: OXTABS HEX: 00000004 ; inline +: ONOEOT HEX: 00000008 ; inline + +! cflags +: CIGNORE HEX: 00000001 ; inline +: CSIZE HEX: 00000300 ; inline +: CS5 HEX: 00000000 ; inline +: CS6 HEX: 00000100 ; inline +: CS7 HEX: 00000200 ; inline +: CS8 HEX: 00000300 ; inline +: CSTOPB HEX: 00000400 ; inline +: CREAD HEX: 00000800 ; inline +: PARENB HEX: 00001000 ; inline +: PARODD HEX: 00002000 ; inline +: HUPCL HEX: 00004000 ; inline +: CLOCAL HEX: 00008000 ; inline +: CCTS_OFLOW HEX: 00010000 ; inline +: CRTS_IFLOW HEX: 00020000 ; inline +: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline +: CDTR_IFLOW HEX: 00040000 ; inline +: CDSR_OFLOW HEX: 00080000 ; inline +: CCAR_OFLOW HEX: 00100000 ; inline +: MDMBUF HEX: 00100000 ; inline + +! lflags +: ECHOKE HEX: 00000001 ; inline +: ECHOE HEX: 00000002 ; inline +: ECHOK HEX: 00000004 ; inline +: ECHO HEX: 00000008 ; inline +: ECHONL HEX: 00000010 ; inline +: ECHOPRT HEX: 00000020 ; inline +: ECHOCTL HEX: 00000040 ; inline +: ISIG HEX: 00000080 ; inline +: ICANON HEX: 00000100 ; inline +: ALTWERASE HEX: 00000200 ; inline +: IEXTEN HEX: 00000400 ; inline +: EXTPROC HEX: 00000800 ; inline +: TOSTOP HEX: 00400000 ; inline +: FLUSHO HEX: 00800000 ; inline +: NOKERNINFO HEX: 02000000 ; inline +: PENDIN HEX: 20000000 ; inline +: NOFLSH HEX: 80000000 ; inline diff --git a/extra/serial/unix/bsd/tags.txt b/extra/serial/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/linux/linux.factor b/extra/serial/unix/linux/linux.factor new file mode 100644 index 0000000000..3ad5088fc8 --- /dev/null +++ b/extra/serial/unix/linux/linux.factor @@ -0,0 +1,130 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs alien.syntax kernel serial system unix ; +IN: serial.unix + +: TCSANOW 0 ; inline +: TCSADRAIN 1 ; inline +: TCSAFLUSH 2 ; inline + +: TCIFLUSH 0 ; inline +: TCOFLUSH 1 ; inline +: TCIOFLUSH 2 ; inline + +: TCOOFF 0 ; inline +: TCOON 1 ; inline +: TCIOFF 2 ; inline +: TCION 3 ; inline + +! iflag +: IGNBRK OCT: 0000001 ; inline +: BRKINT OCT: 0000002 ; inline +: IGNPAR OCT: 0000004 ; inline +: PARMRK OCT: 0000010 ; inline +: INPCK OCT: 0000020 ; inline +: ISTRIP OCT: 0000040 ; inline +: INLCR OCT: 0000100 ; inline +: IGNCR OCT: 0000200 ; inline +: ICRNL OCT: 0000400 ; inline +: IUCLC OCT: 0001000 ; inline +: IXON OCT: 0002000 ; inline +: IXANY OCT: 0004000 ; inline +: IXOFF OCT: 0010000 ; inline +: IMAXBEL OCT: 0020000 ; inline +: IUTF8 OCT: 0040000 ; inline + +! oflag +: OPOST OCT: 0000001 ; inline +: OLCUC OCT: 0000002 ; inline +: ONLCR OCT: 0000004 ; inline +: OCRNL OCT: 0000010 ; inline +: ONOCR OCT: 0000020 ; inline +: ONLRET OCT: 0000040 ; inline +: OFILL OCT: 0000100 ; inline +: OFDEL OCT: 0000200 ; inline +: NLDLY OCT: 0000400 ; inline +: NL0 OCT: 0000000 ; inline +: NL1 OCT: 0000400 ; inline +: CRDLY OCT: 0003000 ; inline +: CR0 OCT: 0000000 ; inline +: CR1 OCT: 0001000 ; inline +: CR2 OCT: 0002000 ; inline +: CR3 OCT: 0003000 ; inline +: TABDLY OCT: 0014000 ; inline +: TAB0 OCT: 0000000 ; inline +: TAB1 OCT: 0004000 ; inline +: TAB2 OCT: 0010000 ; inline +: TAB3 OCT: 0014000 ; inline +: BSDLY OCT: 0020000 ; inline +: BS0 OCT: 0000000 ; inline +: BS1 OCT: 0020000 ; inline +: FFDLY OCT: 0100000 ; inline +: FF0 OCT: 0000000 ; inline +: FF1 OCT: 0100000 ; inline + +! cflags +: CSIZE OCT: 0000060 ; inline +: CS5 OCT: 0000000 ; inline +: CS6 OCT: 0000020 ; inline +: CS7 OCT: 0000040 ; inline +: CS8 OCT: 0000060 ; inline +: CSTOPB OCT: 0000100 ; inline +: CREAD OCT: 0000200 ; inline +: PARENB OCT: 0000400 ; inline +: PARODD OCT: 0001000 ; inline +: HUPCL OCT: 0002000 ; inline +: CLOCAL OCT: 0004000 ; inline +: CIBAUD OCT: 002003600000 ; inline +: CRTSCTS OCT: 020000000000 ; inline + +! lflags +: ISIG OCT: 0000001 ; inline +: ICANON OCT: 0000002 ; inline +: XCASE OCT: 0000004 ; inline +: ECHO OCT: 0000010 ; inline +: ECHOE OCT: 0000020 ; inline +: ECHOK OCT: 0000040 ; inline +: ECHONL OCT: 0000100 ; inline +: NOFLSH OCT: 0000200 ; inline +: TOSTOP OCT: 0000400 ; inline +: ECHOCTL OCT: 0001000 ; inline +: ECHOPRT OCT: 0002000 ; inline +: ECHOKE OCT: 0004000 ; inline +: FLUSHO OCT: 0010000 ; inline +: PENDIN OCT: 0040000 ; inline +: IEXTEN OCT: 0100000 ; inline + +M: linux lookup-baud ( n -- n ) + dup H{ + { 0 OCT: 0000000 } + { 50 OCT: 0000001 } + { 75 OCT: 0000002 } + { 110 OCT: 0000003 } + { 134 OCT: 0000004 } + { 150 OCT: 0000005 } + { 200 OCT: 0000006 } + { 300 OCT: 0000007 } + { 600 OCT: 0000010 } + { 1200 OCT: 0000011 } + { 1800 OCT: 0000012 } + { 2400 OCT: 0000013 } + { 4800 OCT: 0000014 } + { 9600 OCT: 0000015 } + { 19200 OCT: 0000016 } + { 38400 OCT: 0000017 } + { 57600 OCT: 0010001 } + { 115200 OCT: 0010002 } + { 230400 OCT: 0010003 } + { 460800 OCT: 0010004 } + { 500000 OCT: 0010005 } + { 576000 OCT: 0010006 } + { 921600 OCT: 0010007 } + { 1000000 OCT: 0010010 } + { 1152000 OCT: 0010011 } + { 1500000 OCT: 0010012 } + { 2000000 OCT: 0010013 } + { 2500000 OCT: 0010014 } + { 3000000 OCT: 0010015 } + { 3500000 OCT: 0010016 } + { 4000000 OCT: 0010017 } + } at* [ nip ] [ drop invalid-baud ] if ; diff --git a/extra/serial/unix/linux/tags.txt b/extra/serial/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/tags.txt b/extra/serial/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/bsd/bsd.factor b/extra/serial/unix/termios/bsd/bsd.factor new file mode 100644 index 0000000000..5fbc571519 --- /dev/null +++ b/extra/serial/unix/termios/bsd/bsd.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel sequences system ; +IN: serial.unix.termios + +: NCCS 20 ; inline + +TYPEDEF: uint tcflag_t +TYPEDEF: uchar cc_t +TYPEDEF: uint speed_t + +C-STRUCT: termios + { "tcflag_t" "iflag" } ! input mode flags + { "tcflag_t" "oflag" } ! output mode flags + { "tcflag_t" "cflag" } ! control mode flags + { "tcflag_t" "lflag" } ! local mode flags + { { "cc_t" NCCS } "cc" } ! control characters + { "speed_t" "ispeed" } ! input speed + { "speed_t" "ospeed" } ; ! output speed diff --git a/extra/serial/unix/termios/bsd/tags.txt b/extra/serial/unix/termios/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/linux/linux.factor b/extra/serial/unix/termios/linux/linux.factor new file mode 100644 index 0000000000..de9906e2b9 --- /dev/null +++ b/extra/serial/unix/termios/linux/linux.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel system unix ; +IN: serial.unix.termios + +: NCCS 32 ; inline + +TYPEDEF: uchar cc_t +TYPEDEF: uint speed_t +TYPEDEF: uint tcflag_t + +C-STRUCT: termios + { "tcflag_t" "iflag" } ! input mode flags + { "tcflag_t" "oflag" } ! output mode flags + { "tcflag_t" "cflag" } ! control mode flags + { "tcflag_t" "lflag" } ! local mode flags + { "cc_t" "line" } ! line discipline + { { "cc_t" NCCS } "cc" } ! control characters + { "speed_t" "ispeed" } ! input speed + { "speed_t" "ospeed" } ; ! output speed diff --git a/extra/serial/unix/termios/linux/tags.txt b/extra/serial/unix/termios/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/tags.txt b/extra/serial/unix/termios/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/termios.factor b/extra/serial/unix/termios/termios.factor new file mode 100644 index 0000000000..901416d62c --- /dev/null +++ b/extra/serial/unix/termios/termios.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators system vocabs.loader ; +IN: serial.unix.termios + +{ + { [ os linux? ] [ "serial.unix.termios.linux" ] } + { [ os bsd? ] [ "serial.unix.termios.bsd" ] } +} cond require diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor new file mode 100644 index 0000000000..bab6c3f4f1 --- /dev/null +++ b/extra/serial/unix/unix-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math.bitfields serial serial.unix ; +IN: serial.unix + +: serial-obj ( -- obj ) + serial new + "/dev/ttyS0" >>path + 19200 >>baud + { IGNPAR ICRNL } flags >>iflag + { } flags >>oflag + { CS8 CLOCAL CREAD } flags >>cflag + { ICANON } flags >>lflag ; + +: serial-test ( -- serial ) + serial-obj + open-serial + dup get-termios >>termios + dup configure-termios + dup tciflush + dup apply-termios ; diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor new file mode 100644 index 0000000000..7ed5bced37 --- /dev/null +++ b/extra/serial/unix/unix.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.syntax combinators io.ports +io.streams.duplex io.unix.backend system kernel math math.bitfields +vocabs.loader unix serial serial.unix.termios ; +IN: serial.unix + +<< { + { [ os linux? ] [ "serial.unix.linux" ] } + { [ os bsd? ] [ "serial.unix.bsd" ] } +} cond require >> + +FUNCTION: speed_t cfgetispeed ( termios* t ) ; +FUNCTION: speed_t cfgetospeed ( termios* t ) ; +FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ; +FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ; +FUNCTION: int tcgetattr ( int i1, termios* t ) ; +FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ; +FUNCTION: int tcdrain ( int i1 ) ; +FUNCTION: int tcflow ( int i1, int i2 ) ; +FUNCTION: int tcflush ( int i1, int i2 ) ; +FUNCTION: int tcsendbreak ( int i1, int i2 ) ; +FUNCTION: void cfmakeraw ( termios* t ) ; +FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ; + +: fd>duplex-stream ( fd -- duplex-stream ) + init-fd + [ ] [ ] bi ; + +: open-rw ( path -- fd ) O_RDWR file-mode open-file ; +: ( path -- stream ) open-rw fd>duplex-stream ; + +M: unix open-serial ( serial -- serial' ) + dup + path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file + fd>duplex-stream >>stream ; + +: serial-fd ( serial -- fd ) + stream>> in>> handle>> fd>> ; + +: get-termios ( serial -- termios ) + serial-fd + "termios" [ tcgetattr io-error ] keep ; + +: configure-termios ( serial -- ) + dup termios>> + { + [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ] + [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ] + [ + [ + [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor + ] dip set-termios-cflag + ] + [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ] + } 2cleave ; + +: tciflush ( serial -- ) + serial-fd TCIFLUSH tcflush io-error ; + +: apply-termios ( serial -- ) + [ serial-fd TCSANOW ] + [ termios>> ] bi tcsetattr io-error ; diff --git a/extra/taxes/tags.txt b/extra/taxes/tags.txt index 8b13789179..2964ef21b1 100644 --- a/extra/taxes/tags.txt +++ b/extra/taxes/tags.txt @@ -1 +1 @@ - +taxes diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 5522dd9bcb..5e2a395c40 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -1,5 +1,7 @@ -USING: arrays assocs kernel math math.intervals namespaces -sequences combinators.lib money math.order ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs kernel math math.intervals +namespaces sequences combinators.lib money math.order ; IN: taxes : monthly ( x -- y ) 12 / ; @@ -14,22 +16,21 @@ C: w4 : allowance ( -- x ) 3500 ; inline -: calculate-w4-allowances ( w4 -- x ) - w4-allowances allowance * ; +: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ; ! Withhold: FICA, Medicare, Federal (FICA is social security) : fica-tax-rate ( -- x ) DECIMAL: .062 ; inline ! Base rate -- income over this rate is not taxed -TUPLE: fica-base-unknown ; +ERROR: fica-base-unknown ; : fica-base-rate ( year -- x ) H{ { 2008 102000 } { 2007 97500 } - } at* [ T{ fica-base-unknown } throw ] unless ; + } at* [ fica-base-unknown ] unless ; : fica-tax ( salary w4 -- x ) - w4-year fica-base-rate min fica-tax-rate * ; + year>> fica-base-rate min fica-tax-rate * ; ! Employer tax only, not withheld : futa-tax-rate ( -- x ) DECIMAL: .062 ; inline @@ -64,8 +65,7 @@ TUPLE: tax-table single married ; 0 -rot [ tax-bracket ] each drop ; : marriage-table ( w4 tax-table -- triples ) - swap w4-married? - [ tax-table-married ] [ tax-table-single ] if ; + swap married?>> [ married>> ] [ single>> ] if ; : federal-tax ( salary w4 tax-table -- n ) [ adjust-allowances ] 2keep marriage-table tax ; diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor new file mode 100644 index 0000000000..098919c868 --- /dev/null +++ b/unfinished/compiler/cfg/builder/builder-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.cfg.builder.tests +USING: compiler.cfg.builder tools.test ; + +\ build-cfg must-infer diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor index 2f68864e81..76a1b67dd2 100644 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -1,29 +1,33 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel assocs sequences sequences.lib fry accessors -compiler.cfg compiler.vops compiler.vops.builder -namespaces math inference.dataflow optimizer.allot combinators -math.order ; +namespaces math combinators math.order +compiler.tree +compiler.tree.combinators +compiler.tree.propagation.info +compiler.cfg +compiler.vops +compiler.vops.builder ; IN: compiler.cfg.builder -! Convert dataflow IR to procedure CFG. +! Convert tree SSA IR to CFG SSA IR. + ! We construct the graph and set successors first, then we ! set predecessors in a separate pass. This simplifies the ! logic. SYMBOL: procedures -SYMBOL: values>vregs - SYMBOL: loop-nesting -GENERIC: convert* ( node -- ) +SYMBOL: values>vregs GENERIC: convert ( node -- ) +M: #introduce convert drop ; + : init-builder ( -- ) - H{ } clone values>vregs set - V{ } clone loop-nesting set ; + H{ } clone values>vregs set ; : end-basic-block ( -- ) basic-block get [ %b emit ] when ; @@ -40,15 +44,12 @@ GENERIC: convert ( node -- ) set-basic-block ; : convert-nodes ( node -- ) - dup basic-block get and [ - [ convert ] [ successor>> convert-nodes ] bi - ] [ drop ] if ; + [ convert ] each ; : (build-cfg) ( node word -- ) init-builder begin-basic-block basic-block get swap procedures get set-at - %prolog emit convert-nodes ; : build-cfg ( node word -- procedures ) @@ -73,10 +74,9 @@ GENERIC: convert ( node -- ) 2bi ] if ; -: load-inputs ( node -- ) - [ in-d>> %data (load-inputs) ] - [ in-r>> %retain (load-inputs) ] - bi ; +: load-in-d ( node -- ) in-d>> %data (load-inputs) ; + +: load-in-r ( node -- ) in-r>> %retain (load-inputs) ; : (store-outputs) ( seq stack -- ) over empty? [ 2drop ] [ @@ -86,40 +86,21 @@ GENERIC: convert ( node -- ) 2bi ] if ; -: store-outputs ( node -- ) - [ out-d>> %data (store-outputs) ] - [ out-r>> %retain (store-outputs) ] - bi ; +: store-out-d ( node -- ) out-d>> %data (store-outputs) ; -M: #push convert* - out-d>> [ - [ produce-vreg ] [ value-literal ] bi - emit-literal - ] each ; - -M: #shuffle convert* drop ; - -M: #>r convert* drop ; - -M: #r> convert* drop ; - -M: node convert - [ load-inputs ] - [ convert* ] - [ store-outputs ] - tri ; +: store-out-r ( node -- ) out-r>> %retain (store-outputs) ; : (emit-call) ( word -- ) begin-basic-block %call emit begin-basic-block ; : intrinsic-inputs ( node -- ) - [ load-inputs ] + [ load-in-d ] [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ] bi ; : intrinsic-outputs ( node -- ) [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ] - [ store-outputs ] + [ store-out-d ] bi ; : intrinsic ( node quot -- ) @@ -132,19 +113,17 @@ M: node convert tri ] with-scope ; inline -USING: kernel.private math.private slots.private -optimizer.allot ; +USING: kernel.private math.private slots.private ; : maybe-emit-fixnum-shift-fast ( node -- node ) - dup dup in-d>> second node-literal? [ - dup dup in-d>> second node-literal + dup dup in-d>> second node-value-info literal>> dup fixnum? [ '[ , emit-fixnum-shift-fast ] intrinsic ] [ - dup param>> (emit-call) + drop dup word>> (emit-call) ] if ; : emit-call ( node -- ) - dup param>> { + dup word>> { { \ tag [ [ emit-tag ] intrinsic ] } { \ slot [ [ dup emit-slot ] intrinsic ] } @@ -175,24 +154,43 @@ optimizer.allot ; { \ float> [ [ emit-float> ] intrinsic ] } { \ float? [ [ emit-float= ] intrinsic ] } - { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } - { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } - { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } + ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } + ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } + ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } [ (emit-call) ] } case drop ; M: #call convert emit-call ; -M: #call-label convert - dup param>> loop-nesting get at [ - basic-block get successors>> push - end-basic-block - basic-block off - drop - ] [ - (emit-call) - ] if* ; +: emit-call-loop ( #recursive -- ) + dup label>> loop-nesting get at basic-block get successors>> push + end-basic-block + basic-block off + drop ; + +: emit-call-recursive ( #recursive -- ) + label>> id>> (emit-call) ; + +M: #call-recursive convert + dup label>> loop?>> + [ emit-call-loop ] [ emit-call-recursive ] if ; + +M: #push convert + [ + [ out-d>> first produce-vreg ] + [ node-output-infos first literal>> ] + bi emit-literal + ] + [ store-out-d ] bi ; + +M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ; + +M: #>r convert [ load-in-d ] [ store-out-r ] bi ; + +M: #r> convert [ load-in-r ] [ store-out-d ] bi ; + +M: #terminate convert drop ; : integer-conditional ( in1 in2 cc -- ) [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline @@ -221,50 +219,38 @@ M: #call-label convert [ set-basic-block ] bi ; -: phi-inputs ( #if -- vregs-seq ) - children>> - [ last-node ] map - [ #values? ] filter - [ in-d>> [ value>vreg ] map ] map ; - -: phi-outputs ( #if -- vregs ) - successor>> out-d>> [ produce-vreg ] map ; - -: emit-phi ( #if -- ) - [ phi-outputs ] [ phi-inputs ] bi %phi emit ; - M: #if convert - { - [ load-inputs ] - [ emit-if ] - [ convert-if-children ] - [ emit-phi ] - } cleave ; + [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ; -M: #values convert drop ; +M: #dispatch convert + "Unimplemented" throw ; -M: #merge convert drop ; - -M: #entry convert drop ; +M: #phi convert drop ; M: #declare convert drop ; -M: #terminate convert drop ; +M: #return convert drop %return emit ; -M: #label convert - #! Labels create a new procedure. - [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ; +: convert-recursive ( #recursive -- ) + [ [ label>> id>> ] [ child>> ] bi (build-cfg) ] + [ (emit-call) ] + bi ; -M: #loop convert - #! Loops become part of the current CFG. - begin-basic-block - [ param>> basic-block get 2array loop-nesting get push ] - [ node-child convert-nodes ] - bi +: begin-loop ( #recursive -- ) + label>> basic-block get 2array loop-nesting get push ; + +: end-loop ( -- ) loop-nesting get pop* ; -M: #return convert - param>> loop-nesting get key? [ - %epilog emit - %return emit - ] unless ; +: convert-loop ( #recursive -- ) + begin-basic-block + [ begin-loop ] + [ child>> convert-nodes ] + [ drop end-loop ] + tri ; + +M: #recursive convert + dup label>> loop?>> + [ convert-loop ] [ convert-recursive ] if ; + +M: #copy convert drop ; diff --git a/unfinished/compiler/generator/authors.txt b/unfinished/compiler/generator/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/generator/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/generator/fixup/authors.txt b/unfinished/compiler/generator/fixup/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/generator/fixup/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/generator/fixup/fixup-docs.factor b/unfinished/compiler/generator/fixup/fixup-docs.factor new file mode 100644 index 0000000000..a4ff549e8e --- /dev/null +++ b/unfinished/compiler/generator/fixup/fixup-docs.factor @@ -0,0 +1,16 @@ +USING: help.syntax help.markup math kernel +words strings alien ; +IN: compiler.generator.fixup + +HELP: frame-required +{ $values { "n" "a non-negative integer" } } +{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ; + +HELP: add-literal +{ $values { "obj" object } { "n" integer } } +{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; + +HELP: rel-dlsym +{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } } +{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats." +} ; diff --git a/unfinished/compiler/generator/fixup/fixup.factor b/unfinished/compiler/generator/fixup/fixup.factor new file mode 100755 index 0000000000..e1b4e42e67 --- /dev/null +++ b/unfinished/compiler/generator/fixup/fixup.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays generic assocs hashtables io.binary +kernel kernel.private math namespaces sequences words +quotations strings alien.accessors alien.strings layouts system +combinators math.bitfields words.private cpu.architecture +math.order accessors growable ; +IN: compiler.generator.fixup + +: no-stack-frame -1 ; inline + +TUPLE: frame-required n ; + +: frame-required ( n -- ) \ frame-required boa , ; + +: stack-frame-size ( code -- n ) + no-stack-frame [ + dup frame-required? [ frame-required-n max ] [ drop ] if + ] reduce ; + +GENERIC: fixup* ( frame-size obj -- frame-size ) + +: code-format 22 getenv ; + +: compiled-offset ( -- n ) building get length code-format * ; + +TUPLE: label offset ; + +: