From 94baa7d7fa084ffed47aa1e2240b268c9e6ef8f7 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 8 Apr 2009 18:12:27 -0500 Subject: [PATCH 01/56] Call ScriptStringOut with ETO_OPAQUE --- basis/windows/uniscribe/uniscribe.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 7cfda41dc9..f6cacfb683 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ; ssa>> ! ssa 0 ! iX 0 ! iY - 0 ! uOptions - f ! prc + ETO_OPAQUE ! uOptions ] - [ selection-start/end ] bi + [ [ { 0 0 } ] dip size>> ] + [ selection-start/end ] tri ! iMinSel ! iMaxSel FALSE ! fDisabled @@ -108,7 +108,7 @@ M: script-string dispose* SYMBOL: cached-script-strings -: cached-script-string ( string font -- script-string ) +: cached-script-string ( font string -- script-string ) cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] From 49852f57153cd24e23912d8b4efd7c00a4e86f3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Apr 2009 18:42:01 -0500 Subject: [PATCH 02/56] fix saving bitmaps --- basis/images/bitmap/bitmap-tests.factor | 28 +++++++++++- basis/images/bitmap/bitmap.factor | 60 +++++++++++++++---------- 2 files changed, 62 insertions(+), 26 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index e154df26a1..c7012cfd42 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,6 +1,6 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences ; +literals sequences checksums.md5 checksums ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -11,6 +11,11 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp" CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" +CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp" +CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" +CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" +CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" + [ t ] [ test-bitmap24 @@ -24,4 +29,23 @@ CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" $ test-bitmap8 $ test-bitmap24 "vocab:ui/render/test/reference.bmp" -} [ [ ] swap [ load-image drop ] curry unit-test ] each \ No newline at end of file +} [ [ ] swap [ load-image drop ] curry unit-test ] each + + +: test-bitmap-save ( path -- ? ) + [ md5 checksum-file ] + [ load-image ] bi + "bitmap-save-test" unique-file + [ save-bitmap ] + [ md5 checksum-file ] bi = ; + +[ + t +] [ + { + $ test-40 + $ test-41 + $ test-42 + $ test-43 + } [ test-bitmap-save ] all? +] unit-test diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8209159a8e..48095bb26b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -37,14 +37,14 @@ M: bitmap-magic summary ERROR: bmp-not-supported n ; : reverse-lines ( byte-array width -- byte-array ) - 3 * concat ; inline + concat ; inline : raw-bitmap>seq ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] } - { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] } + { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } + { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } [ bmp-not-supported ] } case >byte-array ; @@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ; : image-size ( loading-bitmap -- n ) [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; +: bitmap-padding ( width -- n ) + 3 * 4 mod 4 swap - 4 mod ; inline + :: fixup-color-index ( loading-bitmap -- loading-bitmap ) loading-bitmap width>> :> width width 3 * :> width*3 - loading-bitmap height>> abs :> height - loading-bitmap color-index>> length :> color-index-length - color-index-length height /i :> stride - color-index-length width*3 height * - height /i :> padding + loading-bitmap width>> bitmap-padding :> padding + loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride + loading-bitmap padding 0 > [ - loading-bitmap [ + [ stride [ width*3 head-slice ] map concat ] change-color-index - ] [ - loading-bitmap - ] if ; + ] when ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index fixup-color-index ; -: load-bitmap-data ( path loading-bitmap -- loading-bitmap ) - [ binary ] dip '[ - _ parse-file-header parse-bitmap-header parse-bitmap +: load-bitmap-data ( path -- loading-bitmap ) + binary [ + loading-bitmap new + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; ERROR: unknown-component-order bitmap ; @@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image ) - [ bitmap-image new ] dip +: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) { [ raw-bitmap>seq >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] @@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ; } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - drop loading-bitmap new - load-bitmap-data - loading-bitmap>bitmap-image ; + swap load-bitmap-data loading-bitmap>bitmap-image ; PRIVATE> -: bitmap>color-index ( bitmap-array -- byte-array ) - 4 [ 3 head-slice ] map B{ } join ; inline +: bitmap>color-index ( bitmap -- byte-array ) + [ + bitmap>> + 4 + [ 3 head-slice ] map + B{ } join + ] [ + dim>> first dup bitmap-padding dup 0 > [ + [ 3 * group ] dip '[ _ append ] map + B{ } join + ] [ + 2drop + ] if + ] bi ; : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - bitmap>> bitmap>color-index length 14 + 40 + write4 + bitmap>color-index length 14 + 40 + write4 0 write4 54 write4 40 write4 @@ -159,7 +169,7 @@ PRIVATE> [ drop 0 write4 ] ! size-image - [ bitmap>> bitmap>color-index length write4 ] + [ bitmap>color-index length write4 ] ! x-pels [ drop 0 write4 ] @@ -175,7 +185,9 @@ PRIVATE> ! rgb-quads [ - [ bitmap>> bitmap>color-index ] [ dim>> first ] bi + [ bitmap>color-index ] + [ dim>> first 3 * ] + [ dim>> first bitmap-padding + ] tri reverse-lines write ] } cleave From 07cf80f0a8b1c1c105e4a7eb89263bfb3fb48e4b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Apr 2009 18:42:26 -0500 Subject: [PATCH 03/56] fix stack effect for unique-file --- basis/io/files/unique/unique-docs.factor | 2 +- basis/io/files/unique/unique.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 74fc045032..6a7be47813 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -62,8 +62,8 @@ HELP: current-temporary-directory HELP: unique-file { $values + { "prefix" string } { "path" "a pathname string" } - { "path'" "a pathname string" } } { $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ; diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 7bd96aa63b..0e4338e3e0 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -64,7 +64,7 @@ PRIVATE> [ unique-directory ] dip '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline -: unique-file ( path -- path' ) +: unique-file ( prefix -- path ) "" make-unique-file ; { From 1c70bf833f105d4628c99f261290a92b7a9f592f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 5 Mar 2009 23:11:46 -0200 Subject: [PATCH 04/56] irc: IRC messages reimplemented --- extra/irc/client/client-docs.factor | 8 +- extra/irc/client/client-tests.factor | 14 +- extra/irc/client/client.factor | 57 +++--- extra/irc/messages/base/authors.txt | 1 + extra/irc/messages/base/base.factor | 115 ++++++++++++ extra/irc/messages/base/summary.txt | 1 + extra/irc/messages/messages-tests.factor | 30 ++- extra/irc/messages/messages.factor | 230 ++++++----------------- extra/irc/messages/parser/authors.txt | 1 + extra/irc/messages/parser/parser.factor | 35 ++++ extra/irc/messages/parser/summary.txt | 1 + extra/irc/messages/summary.txt | 1 + 12 files changed, 262 insertions(+), 232 deletions(-) create mode 100644 extra/irc/messages/base/authors.txt create mode 100644 extra/irc/messages/base/base.factor create mode 100644 extra/irc/messages/base/summary.txt create mode 100644 extra/irc/messages/parser/authors.txt create mode 100644 extra/irc/messages/parser/parser.factor create mode 100644 extra/irc/messages/parser/summary.txt create mode 100644 extra/irc/messages/summary.txt diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 6d4fae9b83..d95d2bc2c6 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax quotations kernel irc.messages ; +USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; IN: irc.client HELP: irc-client "IRC Client object" ; @@ -56,15 +56,15 @@ ARTICLE: "irc.client" "IRC Client" "Some of the RFC defined irc messages as objects:" { $table { { $link irc-message } "base of all irc messages" } - { { $link logged-in } "logged in to server" } + { { $link rpl-welcome } "logged in to server" } { { $link ping } "ping message" } { { $link join } "channel join" } { { $link part } "channel part" } { { $link quit } "quit from irc" } { { $link privmsg } "private message (to client or channel)" } { { $link kick } "kick from channel" } - { { $link roomlist } "list of participants in channel" } - { { $link nick-in-use } "chosen nick is in use by another client" } + { { $link rpl-names } "list of participants in channel" } + { { $link rpl-nickname-in-use } "chosen nick is in use by another client" } { { $link notice } "notice message" } { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index c1cbdcf8b8..4f25531eee 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes assocs combinators ; + calendar irc.client.private irc.client irc.messages + concurrency.mailboxes classes assocs combinators irc.messages.parser ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -49,13 +49,13 @@ M: mb-writer dispose drop ; { "factorbot" } [ irc> nick>> ] unit-test - { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test +! { "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 + string>irc-message forward-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line forward-name ] unit-test + string>irc-message forward-name ] unit-test ] with-irc ! Test login and nickname set @@ -102,7 +102,7 @@ M: mb-writer dispose drop ; "#factortest" [ %add-named-chat ] keep ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc @@ -110,7 +110,7 @@ M: mb-writer dispose drop ; "ircuser" [ %add-named-chat ] keep ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 97fa659209..7986a726ba 100755 --- 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 fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages ; + ascii irc.messages irc.messages.base irc.messages.parser call ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -74,12 +74,12 @@ SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established : terminate-irc ( irc-client -- ) - [ is-running>> ] keep and [ + dup is-running>> [ f >>is-running [ stream>> dispose ] keep [ in-messages>> ] [ out-messages>> ] bi 2array [ irc-end swap mailbox-put ] each - ] when* ; + ] [ drop ] if ; > mailbox-put ; : chats-with-participant ( nick -- seq ) irc> chats>> values - [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ] + [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; : to-chats-with-participant ( message nickname -- ) @@ -165,11 +165,10 @@ M: irc-chat to-chat in-messages>> mailbox-put ; " hostname servername :irc.factor" irc-print ; : /CONNECT ( server port -- stream ) - irc> connect>> call drop ; inline + irc> connect>> call( host port -- stream local ) drop ; : /JOIN ( channel password -- ) - "JOIN " irc-write - [ [ " :" ] dip 3append ] when* irc-print ; + "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -187,7 +186,7 @@ M: join forward-name trailing>> ; M: part forward-name channel>> ; M: kick forward-name channel>> ; M: mode forward-name name>> ; -M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ; +M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; UNION: single-forward join part kick mode privmsg ; UNION: multiple-forward nick quit ; @@ -200,48 +199,48 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup irc-message-sender to-chats-with-participant ; + dup sender>> to-chats-with-participant ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; GENERIC: process-message ( irc-message -- ) M: object process-message drop ; -M: logged-in process-message - name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri +M: rpl-welcome process-message + nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri values [ initialize-chat ] each ; M: ping process-message trailing>> /PONG ; -M: nick-in-use process-message name>> "_" append /NICK ; +M: rpl-nickname-in-use process-message name>> "_" append /NICK ; M: join process-message - [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri + [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri dup chat> [ add-participant ] [ 3drop ] if ; M: part process-message - [ irc-message-sender ] [ channel>> ] bi remove-participant ; + [ sender>> ] [ channel>> ] bi remove-participant ; M: kick process-message - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-chat ] [ drop ] if ] + [ [ user>> ] [ channel>> ] bi remove-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] bi ; M: quit process-message - irc-message-sender remove-participant-from-all ; + sender>> remove-participant-from-all ; M: nick process-message - [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; + [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; M: mode process-message ( mode -- ) - [ channel-mode? ] keep and [ + dup channel-mode? [ [ name>> ] [ mode>> ] [ parameter>> ] tri [ change-participant-mode ] [ 2drop ] if* - ] when* ; + ] [ drop ] if ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) - trailing>> [ blank? ] trim " " split + nicks>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; : maybe-clean-participants ( channel-chat -- ) @@ -249,14 +248,14 @@ M: mode process-message ( mode -- ) H{ } clone >>participants f >>clean-participants ] when drop ; -M: names-reply process-message +M: rpl-names process-message [ names-reply>participants ] [ channel>> chat> ] bi [ [ maybe-clean-participants ] [ participants>> 2array assoc-combine ] [ (>>participants) ] tri ] [ drop ] if* ; -M: end-of-names process-message +M: rpl-names-end process-message channel>> chat> [ t >>clean-participants [ f f f ] dip name>> to-chat @@ -268,7 +267,7 @@ M: end-of-names process-message GENERIC: handle-outgoing-irc ( irc-message -- ? ) M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; ! ====================================== ! Reader/Writer @@ -293,9 +292,9 @@ DEFER: (connect-irc) : (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message t + string>irc-message handle-reader-message t ] [ - handle-disconnect + f handle-disconnect ] if* ] with-destructors ; @@ -314,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; + privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } @@ -325,7 +324,7 @@ DEFER: (connect-irc) GENERIC: annotate-message ( chat object -- object ) M: object annotate-message nip ; M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>name ; +M: privmsg annotate-message swap name>> >>target ; M: string annotate-message [ name>> ] dip strings>privmsg ; : spawn-irc ( -- ) @@ -335,7 +334,7 @@ M: string annotate-message [ name>> ] dip strings>privmsg ; 3drop ; GENERIC: (attach-chat) ( irc-chat -- ) -USE: prettyprint + M: irc-chat (attach-chat) [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] diff --git a/extra/irc/messages/base/authors.txt b/extra/irc/messages/base/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/base/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor new file mode 100644 index 0000000000..7350ef9320 --- /dev/null +++ b/extra/irc/messages/base/base.factor @@ -0,0 +1,115 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.parser classes.tuple + combinators fry generic.parser kernel lexer + mirrors namespaces parser sequences splitting strings words ; +IN: irc.messages.base + +TUPLE: irc-message line prefix command parameters trailing timestamp sender ; +TUPLE: unhandled < irc-message ; + +SYMBOL: string-irc-type-mapping +string-irc-type-mapping [ H{ } clone ] initialize + +: register-irc-message-type ( type string -- ) + string-irc-type-mapping get set-at ; + +: irc>type ( string -- irc-message-class ) + string-irc-type-mapping get at unhandled or ; + +GENERIC: irc-trailing-slot ( irc-message -- string/f ) +M: irc-message irc-trailing-slot + drop f ; + +GENERIC: irc-parameter-slots ( irc-message -- seq ) +M: irc-message irc-parameter-slots + drop f ; + +GENERIC: process-irc-trailing ( irc-message -- ) +M: irc-message process-irc-trailing + dup irc-trailing-slot [ + swap [ trailing>> swap ] [ ] bi set-at + ] [ drop ] if* ; + +GENERIC: process-irc-prefix ( irc-message -- ) +M: irc-message process-irc-prefix + drop ; + + + +GENERIC: process-irc-parameters ( irc-message -- ) +M: irc-message process-irc-parameters + dup irc-parameter-slots [ + swap [ parameters>> swap ] [ [slot-setter] ] bi 2each + ] [ drop ] if* ; + +GENERIC: post-process-irc-message ( irc-message -- ) +M: irc-message post-process-irc-message drop ; + +GENERIC: fill-irc-message-slots ( irc-message -- ) +M: irc-message fill-irc-message-slots + { + [ process-irc-trailing ] + [ process-irc-prefix ] + [ process-irc-parameters ] + [ post-process-irc-message ] + } cleave ; + +GENERIC: irc-command-string ( irc-message -- string ) +M: irc-message irc-command-string drop f ; + +! FIXME: inverse of post-process is missing +GENERIC: set-irc-parameters ( irc-message -- ) +M: irc-message set-irc-parameters + dup irc-parameter-slots + [ over '[ _ at ] map >>parameters ] when* drop ; + +GENERIC: set-irc-trailing ( irc-message -- ) +M: irc-message set-irc-trailing + dup irc-trailing-slot [ over at >>trailing ] when* drop ; + +GENERIC: set-irc-command ( irc-message -- ) +M: irc-message set-irc-command + [ irc-command-string ] [ (>>command) ] bi ; + +: irc-message>string ( irc-message -- string ) + { + [ prefix>> ] + [ command>> ] + [ parameters>> " " join ] + [ trailing>> dup [ CHAR: : prefix ] when ] + } cleave 4array sift " " join ; + + + +#! SYNTAX: +#! IRC: type "COMMAND" slot1 ...; +#! IRC: type "COMMAND" slot1 ... : trailing-slot; +: IRC: ( name string parameters -- ) + CREATE-CLASS + [ scan-object register-irc-message-type ] keep + ";" parse-tokens + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing diff --git a/extra/irc/messages/base/summary.txt b/extra/irc/messages/base/summary.txt new file mode 100644 index 0000000000..1a05067707 --- /dev/null +++ b/extra/irc/messages/base/summary.txt @@ -0,0 +1 @@ +IRC messages base implementation diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index ac1d003b1b..abe94de8ef 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -1,19 +1,10 @@ USING: kernel tools.test accessors arrays - irc.messages irc.messages.private ; + irc.messages.parser irc.messages ; EXCLUDE: sequences => join ; IN: irc.messages.tests -{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - -{ T{ irc-message - { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } - { prefix "someuser!n=user@some.where" } - { command "PRIVMSG" } - { parameters { "#factortest" } } - { trailing "hi" } } } -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test +! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { T{ privmsg { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } @@ -21,9 +12,10 @@ IN: irc.messages.tests { command "PRIVMSG" } { parameters { "#factortest" } } { trailing "hi" } - { name "#factortest" } } } + { target "#factortest" } + { text "hi" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ join { line ":someuser!n=user@some.where JOIN :#factortest" } @@ -32,7 +24,7 @@ IN: irc.messages.tests { parameters { } } { trailing "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +ns" } @@ -42,7 +34,7 @@ IN: irc.messages.tests { name "#factortest" } { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +o someuser" } @@ -53,7 +45,7 @@ IN: irc.messages.tests { mode "+o" } { parameter "someuser" } } } [ ":ircserver.net MODE #factortest +o someuser" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ nick { line ":someuser!n=user@some.where NICK :someuser2" } @@ -62,9 +54,9 @@ IN: irc.messages.tests { parameters { } } { trailing "someuser2" } } } [ ":someuser!n=user@some.where NICK :someuser2" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test -{ T{ nick-in-use +{ T{ rpl-nickname-in-use { line ":ircserver.net 433 * nickname :Nickname is already in use" } { prefix "ircserver.net" } { command "433" } @@ -72,4 +64,4 @@ IN: irc.messages.tests { name "nickname" } { trailing "Nickname is already in use" } } } [ ":ircserver.net 433 * nickname :Nickname is already in use" - parse-irc-line f >>timestamp ] unit-test \ No newline at end of file + string>irc-message f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index c88bbc072a..e0f9a15eff 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,179 +1,63 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order ; -RENAME: join sequences => sjoin + arrays classes.tuple math.order words assocs strings + irc.messages.base ; EXCLUDE: sequences => join ; IN: irc.messages -TUPLE: irc-message line prefix command parameters trailing timestamp ; -TUPLE: logged-in < irc-message name ; -TUPLE: ping < irc-message ; -TUPLE: join < irc-message ; -TUPLE: part < irc-message channel ; -TUPLE: quit < irc-message ; -TUPLE: nick < irc-message ; -TUPLE: privmsg < irc-message name ; -TUPLE: kick < irc-message channel who ; -TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message name ; -TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name mode parameter ; -TUPLE: names-reply < irc-message who channel ; -TUPLE: end-of-names < irc-message who channel ; -TUPLE: unhandled < irc-message ; - -: ( command parameters trailing -- irc-message ) - irc-message new - now >>timestamp - swap >>trailing - swap >>parameters - swap >>command ; - -> ( irc-message -- string ) - -M: irc-message command-string>> ( irc-message -- string ) command>> ; -M: ping command-string>> ( ping -- string ) drop "PING" ; -M: join command-string>> ( join -- string ) drop "JOIN" ; -M: part command-string>> ( part -- string ) drop "PART" ; -M: quit command-string>> ( quit -- string ) drop "QUIT" ; -M: nick command-string>> ( nick -- string ) drop "NICK" ; -M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; -M: notice command-string>> ( notice -- string ) drop "NOTICE" ; -M: mode command-string>> ( mode -- string ) drop "MODE" ; -M: kick command-string>> ( kick -- string ) drop "KICK" ; - -GENERIC: command-parameters>> ( irc-message -- seq ) - -M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; -M: ping command-parameters>> ( ping -- seq ) drop { } ; -M: join command-parameters>> ( join -- seq ) drop { } ; -M: part command-parameters>> ( part -- seq ) channel>> 1array ; -M: quit command-parameters>> ( quit -- seq ) drop { } ; -M: nick command-parameters>> ( nick -- seq ) drop { } ; -M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; -M: notice command-parameters>> ( norice -- seq ) type>> 1array ; -M: kick command-parameters>> ( kick -- seq ) - [ channel>> ] [ who>> ] bi 2array ; -M: mode command-parameters>> ( mode -- seq ) - [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; - -GENERIC# >>command-parameters 1 ( irc-message params -- irc-message ) - -M: irc-message >>command-parameters ( irc-message params -- irc-message ) - drop ; - -M: logged-in >>command-parameters ( part params -- part ) - first >>name ; - -M: privmsg >>command-parameters ( privmsg params -- privmsg ) - first >>name ; - -M: notice >>command-parameters ( notice params -- notice ) - first >>type ; - -M: part >>command-parameters ( part params -- part ) - first >>channel ; - -M: kick >>command-parameters ( kick params -- kick ) - first2 [ >>channel ] [ >>who ] bi* ; - -M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use ) - second >>name ; - -M: names-reply >>command-parameters ( names-reply params -- names-reply ) - first3 nip [ >>who ] [ >>channel ] bi* ; - -M: end-of-names >>command-parameters ( names-reply params -- names-reply ) - first2 [ >>who ] [ >>channel ] bi* ; - -M: mode >>command-parameters ( mode params -- mode ) - dup length { - { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] } - { 2 [ first2 [ >>name ] [ >>mode ] bi* ] } - [ drop first >>name dup trailing>> >>mode ] - } case ; - -PRIVATE> - -GENERIC: irc-message>client-line ( irc-message -- string ) - -M: irc-message irc-message>client-line ( irc-message -- string ) - [ command-string>> ] - [ command-parameters>> " " sjoin ] - [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] - tri 3array " " sjoin ; - -GENERIC: irc-message>server-line ( irc-message -- string ) - -M: irc-message irc-message>server-line ( irc-message -- string ) - drop "not implemented yet" ; - -> >>line ] - [ prefix>> >>prefix ] - [ command>> >>command ] - [ trailing>> >>trailing ] - [ timestamp>> >>timestamp ] - [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] - } cleave ; - -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 - now irc-message boa ; - -: irc-message>command ( irc-message -- command ) - [ - command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "366" [ end-of-names ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] - } case new - ] keep copy-message-in ; - -: parse-irc-line ( string -- message ) - string>irc-message irc-message>command ; +! connection +IRC: pass "PASS" password ; +IRC: nick "NICK" nickname ; +IRC: user "USER" user mode _ : realname ; +IRC: oper "OPER" name password ; +IRC: mode "MODE" name mode parameter ; +IRC: service "SERVICE" nickname _ distribution type _ : info ; +IRC: quit "QUIT" : comment ; +IRC: squit "SQUIT" server : comment ; +! channel operations +IRC: join "JOIN" channel ; +IRC: part "PART" channel : comment ; +IRC: topic "TOPIC" channel : topic ; +IRC: names "NAMES" channel ; +IRC: list "LIST" channel ; +IRC: invite "INVITE" nickname channel ; +IRC: kick "KICK" channel user : comment ; +! chating +IRC: privmsg "PRIVMSG" target : text ; +IRC: notice "NOTICE" target : text ; +! server queries +IRC: motd "MOTD" target ; +IRC: lusers "LUSERS" mask target ; +IRC: version "VERSION" target ; +IRC: stats "STATS" query target ; +IRC: links "LINKS" server mask ; +IRC: time "TIME" target ; +IRC: connect "CONNECT" server port remote-server ; +IRC: trace "TRACE" target ; +IRC: admin "ADMIN" target ; +IRC: info "INFO" target ; +! service queries +IRC: servlist "SERVLIST" mask type ; +IRC: squery "SQUERY" service-name : text ; +! user queries +IRC: who "WHO" mask operator ; +IRC: whois "WHOIS" target mask ; +IRC: whowas "WHOWAS" nickname count target ; +! misc +IRC: kill "KILL" nickname : comment ; +IRC: ping "PING" server1 server2 ; +IRC: pong "PONG" server1 server2 ; +IRC: error "ERROR" : message ; +! numeric replies +IRC: rpl-welcome "001" nickname : comment ; +IRC: rpl-whois-user "311" nicnamek user host _ : real-name ; +IRC: rpl-channel-modes "324" channel mode params ; +IRC: rpl-notopic "331" channel : topic ; +IRC: rpl-topic "332" channel : topic ; +IRC: rpl-inviting "341" channel nickname ; +IRC: rpl-names "353" nickname _ channel : nicks ; +IRC: rpl-names-end "366" nickname channel : comment ; +! error replies +IRC: rpl-nickname-in-use "433" _ name ; +IRC: rpl-nick-collision "436" nickname : comment ; diff --git a/extra/irc/messages/parser/authors.txt b/extra/irc/messages/parser/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/parser/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor new file mode 100644 index 0000000000..1fa07fc772 --- /dev/null +++ b/extra/irc/messages/parser/parser.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: kernel fry splitting ascii calendar accessors combinators + arrays classes.tuple math.order words assocs + irc.messages.base sequences ; +IN: irc.messages.parser + +> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ; +PRIVATE> + +: string>irc-message ( string -- irc-message ) + dup split-message + [ [ irc>type new ] [ >>command ] bi ] + [ >>parameters ] + [ >>trailing ] + tri* + [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri + now >>timestamp dup sender >>sender ; diff --git a/extra/irc/messages/parser/summary.txt b/extra/irc/messages/parser/summary.txt new file mode 100644 index 0000000000..7ec732aae1 --- /dev/null +++ b/extra/irc/messages/parser/summary.txt @@ -0,0 +1 @@ +Basic parser for irc messages diff --git a/extra/irc/messages/summary.txt b/extra/irc/messages/summary.txt new file mode 100644 index 0000000000..cf3a8ae07a --- /dev/null +++ b/extra/irc/messages/summary.txt @@ -0,0 +1 @@ +IRC message definitions From 5bfe50018e0d918944bc05c7b2dea4cc2c59e741 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 16:14:49 -0200 Subject: [PATCH 05/56] irc.messages: Update tests --- extra/irc/messages/messages-tests.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index abe94de8ef..d88eeabc73 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -13,7 +13,8 @@ IN: irc.messages.tests { parameters { "#factortest" } } { trailing "hi" } { target "#factortest" } - { text "hi" } } } + { text "hi" } + { sender "someuser" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" string>irc-message f >>timestamp ] unit-test @@ -22,7 +23,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "JOIN" } { parameters { } } - { trailing "#factortest" } } } + { trailing "#factortest" } + { sender "someuser" } } } [ ":someuser!n=user@some.where JOIN :#factortest" string>irc-message f >>timestamp ] unit-test @@ -52,7 +54,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "NICK" } { parameters { } } - { trailing "someuser2" } } } + { trailing "someuser2" } + { sender "someuser" } } } [ ":someuser!n=user@some.where NICK :someuser2" string>irc-message f >>timestamp ] unit-test From 527b50fa5691601997284c2b9d082e0e4d43b01b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:43:25 -0200 Subject: [PATCH 06/56] irc.client: Fix strings>privmsg, add test --- extra/irc/client/client-tests.factor | 5 +++++ extra/irc/client/client.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 4f25531eee..07b9df2ab7 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -58,6 +58,11 @@ M: mb-writer dispose drop ; string>irc-message forward-name ] unit-test ] with-irc +{ privmsg "#channel" "hello" } [ + "#channel" "hello" strings>privmsg + [ class ] [ target>> ] [ trailing>> ] tri +] unit-test + ! Test login and nickname set [ { "factorbot2" } [ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 7986a726ba..c7e90eb802 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -313,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; + " :" prepend append "PRIVMSG " prepend string>irc-message ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } From f3577572ec75ccd4703881233663f505edbf84ad Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:54:28 -0200 Subject: [PATCH 07/56] irc.client: add test --- extra/irc/client/client-tests.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 07b9df2ab7..9e96cc249b 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -34,6 +34,7 @@ M: mb-writer dispose drop ; : %add-named-chat ( chat -- ) irc> attach-chat ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %join ( channel -- ) irc> attach-chat ; +: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; @@ -79,8 +80,7 @@ M: mb-writer dispose drop ; ! Test join [ { "JOIN #factortest" } [ - "#factortest" %join - irc> stream>> out>> lines>> pop + "#factortest" %join %pop-output-line ] unit-test ] with-irc @@ -221,3 +221,10 @@ M: mb-writer dispose drop ; [ participant-changed? ] read-matching-message ] unit-test ] with-irc + +! Send privmsg +[ { "PRIVMSG #factortest :hello" } [ + "#factortest" [ %add-named-chat ] keep + "hello" swap speak %pop-output-line + ] unit-test +] with-irc From 93a3c18c59b99ec86be5f5d52e9e853eaed4e6eb Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 20 Mar 2009 10:15:13 -0300 Subject: [PATCH 08/56] irc.client: Make to-chat work with sequences --- extra/irc/client/client.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index c7e90eb802..ee46cd954a 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -104,6 +104,7 @@ M: string to-chat [ to-chat ] [ drop ] if* ; M: irc-chat to-chat in-messages>> mailbox-put ; +M: sequence to-chat [ to-chat ] with each ; : unregister-chat ( name -- ) irc> chats>> @@ -123,9 +124,6 @@ M: irc-chat to-chat in-messages>> mailbox-put ; [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; -: to-chats-with-participant ( message nickname -- ) - chats-with-participant [ to-chat ] with each ; - : remove-participant-from-all ( nick -- ) dup chats-with-participant [ (remove-participant) ] with each ; @@ -199,7 +197,7 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup sender>> to-chats-with-participant ; + dup sender>> chats-with-participant to-chat ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; From 4cc3dfb3c5e8662708937cd9f01b411946aff72b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 21 Mar 2009 19:45:18 -0300 Subject: [PATCH 09/56] irc.client: Fix, don't try to USE 'call' --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index ee46cd954a..f2d671e30d 100755 --- 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 fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser call ; + ascii irc.messages irc.messages.base irc.messages.parser ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client From 4d722001e9a4e2c2010731b91bc6577f91bd4841 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 8 Apr 2009 23:26:58 -0300 Subject: [PATCH 10/56] irc.messages: use SYNTAX: instead of parsing --- extra/irc/messages/base/base.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index 7350ef9320..d67d226d9b 100644 --- a/extra/irc/messages/base/base.factor +++ b/extra/irc/messages/base/base.factor @@ -108,8 +108,8 @@ PRIVATE> #! SYNTAX: #! IRC: type "COMMAND" slot1 ...; #! IRC: type "COMMAND" slot1 ... : trailing-slot; -: IRC: ( name string parameters -- ) +SYNTAX: IRC: ( name string parameters -- ) CREATE-CLASS [ scan-object register-irc-message-type ] keep ";" parse-tokens - [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; From 694652590f22787357e3c6c71c453a5b0643b257 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:18:26 -0500 Subject: [PATCH 11/56] download word throneeds to ws an error if the request did not return a success code (reported by Chris Double) --- basis/http/client/client.factor | 2 +- basis/http/http-tests.factor | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 805929d27b..307fdd5031 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -165,7 +165,7 @@ ERROR: download-failed response ; present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) - binary [ [ write ] with-http-get drop ] with-file-writer ; + binary [ [ write ] with-http-get check-response drop ] with-file-writer ; : download ( url -- ) dup download-name download-to ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index da50a6f85f..45ad132677 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -392,4 +392,7 @@ SYMBOL: a [ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test -[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test \ No newline at end of file +! Check that download throws errors (reported by Chris Double) +[ "http://localhost/tweet_my_twat" add-port download ] must-fail + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test From 9efa1e0c3126a4faca3748743407d8dc3de3fc5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:23:05 -0500 Subject: [PATCH 12/56] Don't use glTexSubImage2D unless we really have to --- basis/opengl/textures/textures.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index e13e99e10f..1900deb5b8 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -36,10 +36,12 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed [ next-power-of-2 ] map ] unless ; -: (tex-image) ( image -- ) - [ GL_TEXTURE_2D 0 GL_RGBA ] dip - [ dim>> adjust-texture-dim first2 0 ] - [ component-order>> component-order>format f ] bi +: (tex-image) ( image bitmap -- ) + [ + [ GL_TEXTURE_2D 0 GL_RGBA ] dip + [ dim>> adjust-texture-dim first2 0 ] + [ component-order>> component-order>format ] bi + ] dip glTexImage2D ; : (tex-sub-image) ( image -- ) @@ -53,7 +55,9 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed gen-texture [ GL_TEXTURE_BIT [ GL_TEXTURE_2D swap glBindTexture - [ (tex-image) ] [ (tex-sub-image) ] bi + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if ] do-attribs ] keep ; From 1551eacfa2cd47972bbe5e084a82ded6a2b92fbd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 10:44:50 -0500 Subject: [PATCH 13/56] add support for tiff grayscale images --- basis/images/bitmap/bitmap-tests.factor | 15 ++++----------- basis/images/images.factor | 5 +++-- basis/images/loader/loader.factor | 5 ++--- basis/images/tiff/tiff.factor | 3 ++- basis/opengl/textures/textures.factor | 4 +++- basis/windows/uniscribe/uniscribe.factor | 10 +++++----- 6 files changed, 19 insertions(+), 23 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index c7012cfd42..29ba3b9b80 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,6 +1,7 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences checksums.md5 checksums ; +literals sequences checksums.md5 checksums +images.normalization ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -16,15 +17,6 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-image ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test - { $ test-bitmap8 $ test-bitmap24 @@ -34,7 +26,7 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" : test-bitmap-save ( path -- ? ) [ md5 checksum-file ] - [ load-image ] bi + [ load-image normalize-image ] bi "bitmap-save-test" unique-file [ save-bitmap ] [ md5 checksum-file ] bi = ; @@ -47,5 +39,6 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" $ test-41 $ test-42 $ test-43 + $ test-bitmap24 } [ test-bitmap-save ] all? ] unit-test diff --git a/basis/images/images.factor b/basis/images/images.factor index b32953f67c..178b91ab52 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -3,7 +3,7 @@ USING: combinators kernel accessors ; IN: images -SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; @@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; : bytes-per-pixel ( component-order -- n ) { { L [ 1 ] } + { LA [ 2 ] } { BGR [ 3 ] } { RGB [ 3 ] } { BGRA [ 4 ] } @@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file +GENERIC: load-image* ( path tuple -- image ) diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index b8bafc021f..fe33cc8f00 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images images.normalization -io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ; } case ; : load-image ( path -- image ) - dup image-class new load-image* normalize-image ; + dup image-class new load-image* ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 80eaff8140..381cd70d22 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ 2 seq>native-endianness ] } { { 8 8 8 8 } [ ] } { { 8 8 8 } [ ] } + { 8 [ ] } [ unknown-component-order ] } case >>bitmap ; @@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } + { 8 [ L ] } [ unknown-component-order ] } case ; : normalize-alpha-data ( seq -- byte-array ) - ! [ normalize-alpha-data ] change-bitmap B{ } like dup byte-array>float-array 4 diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index e13e99e10f..fdf21c32c2 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -20,6 +20,8 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; +M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ; +M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ; SLOT: display-list @@ -159,4 +161,4 @@ PRIVATE> : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] - [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] if ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index f6cacfb683..fb0c134b9a 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string -io.encodings.utf16n accessors arrays combinators destructors locals -cache namespaces init images.normalization fonts alien.c-types -windows windows.usp10 windows.offscreen windows.gdi32 -windows.ole32 windows.types windows.fonts opengl.textures ; +io.encodings.utf16n accessors arrays combinators destructors +cache namespaces init fonts alien.c-types windows windows.usp10 +windows.offscreen windows.gdi32 windows.ole32 windows.types +windows.fonts opengl.textures locals ; IN: windows.uniscribe TUPLE: script-string font string metrics ssa size image disposed ; @@ -112,4 +112,4 @@ SYMBOL: cached-script-strings cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook \ No newline at end of file +"windows.uniscribe" add-init-hook From 5279bb0efc67e22ebba3b2e8b09ac713e504b0f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 10:46:43 -0500 Subject: [PATCH 14/56] change L to LA for grayscale tiffs --- basis/images/tiff/tiff.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 381cd70d22..6bf1ea2ff1 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -475,7 +475,7 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } - { 8 [ L ] } + { 8 [ LA ] } [ unknown-component-order ] } case ; From cdc3d1b643053a17c16e7b177ada4a242c2db179 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:03:34 -0500 Subject: [PATCH 15/56] more id3 refactoring, support TAG+ --- extra/id3/id3-docs.factor | 28 +++---- extra/id3/id3.factor | 166 ++++++++++++++++++++++++-------------- 2 files changed, 121 insertions(+), 73 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index feb110fab8..c43559a630 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -7,7 +7,7 @@ IN: id3 HELP: mp3>id3 { $values { "path" "a path string" } - { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } } + { "id3/f" "a tuple storing ID3v2 metadata or f" } } { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:" { $list { $link title } @@ -22,49 +22,49 @@ HELP: mp3>id3 HELP: album { $values - { "id3" id3v2-info } - { "album/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: artist { $values - { "id3" id3v2-info } - { "artist/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: comment { $values - { "id3" id3v2-info } - { "comment/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: genre { $values - { "id3" id3v2-info } - { "genre/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: title { $values - { "id3" id3v2-info } - { "title/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: year { $values - { "id3" id3v2-info } - { "year/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: find-id3-frame { $values - { "id3" id3v2-info } { "name" string } + { "id3" id3 } { "name" string } { "obj/f" "object or f" } } { $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ; diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5076a4a8ab..8a235d305d 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search ; +io.directories.search literals ; IN: id3 ( -- object ) id3v1-info new ; inline - -: ( header frames -- object ) - [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ; +: ( -- id3 ) + id3 new + H{ } clone >>frames ; inline :
( -- object ) header new ; inline : ( -- object ) frame new ; inline -: id3v2? ( mmap -- ? ) "ID3" head? ; inline +: id3v2? ( seq -- ? ) "ID3" head? ; inline -: id3v1? ( mmap -- ? ) - { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline +CONSTANT: id3v1-length 128 +CONSTANT: id3v1-offset 128 +CONSTANT: id3v1+-length 227 +CONSTANT: id3v1+-offset $[ 128 227 + ] -: id3v1-frame ( string key -- frame ) - - swap >>frame-id - swap >>data ; inline +: id3v1? ( seq -- ? ) + { + [ length id3v1-offset >= ] + [ id3v1-length tail-slice* "TAG" head? ] + } 1&& ; inline -: id3v1>id3v2 ( id3v1 -- id3v2 ) +: id3v1+? ( seq -- ? ) + { + [ length id3v1+-offset >= ] + [ id3v1+-length tail-slice* "TAG+" head? ] + } 1&& ; inline + +: pair>frame ( string key -- frame/f ) + over [ + + swap >>tag + swap >>data + ] [ + 2drop f + ] if ; inline + +: id3v1>frames ( id3v1 -- seq ) [ { - [ title>> "TIT2" id3v1-frame ] - [ artist>> "TPE1" id3v1-frame ] - [ album>> "TALB" id3v1-frame ] - [ year>> "TYER" id3v1-frame ] - [ comment>> "COMM" id3v1-frame ] - [ genre>> "TCON" id3v1-frame ] + [ title>> "TIT2" pair>frame ] + [ artist>> "TPE1" pair>frame ] + [ album>> "TALB" pair>frame ] + [ year>> "TYER" pair>frame ] + [ comment>> "COMM" pair>frame ] + [ genre>> "TCON" pair>frame ] } cleave - ] output>array f swap ; inline + ] output>array sift ; : >28bitword ( seq -- int ) 0 [ [ 7 shift ] dip bitor ] reduce ; inline @@ -85,10 +106,10 @@ TUPLE: id3v1-info title artist album year comment genre ; : filter-text-data ( data -- filtered ) [ printable? ] filter ; inline -: valid-frame-id? ( id -- ? ) +: valid-tag? ( id -- ? ) [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline -: read-frame-data ( frame mmap -- frame data ) +: read-frame-data ( frame seq -- frame data ) [ 10 over size>> 10 + ] dip filter-text-data ; inline : decode-text ( string -- string' ) @@ -96,28 +117,29 @@ TUPLE: id3v1-info title artist album year comment genre ; { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member? utf16 ascii ? decode ; inline -: (read-frame) ( mmap -- frame ) +: (read-frame) ( seq -- frame ) [ ] dip { - [ 4 head-slice decode-text >>frame-id ] + [ 4 head-slice decode-text >>tag ] [ [ 4 8 ] dip subseq >28bitword >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] } cleave ; inline -: read-frame ( mmap -- frame/f ) - dup 4 head-slice valid-frame-id? +: read-frame ( seq -- frame/f ) + dup 4 head-slice valid-tag? [ (read-frame) ] [ drop f ] if ; inline -: remove-frame ( mmap frame -- mmap ) +: remove-frame ( seq frame -- seq ) size>> 10 + tail-slice ; inline -: read-frames ( mmap -- frames ) - [ dup read-frame dup ] - [ [ remove-frame ] keep ] - produce 2nip ; inline +: frames>assoc ( seq -- assoc ) + [ [ tag>> ] keep ] H{ } map>assoc ; inline + +: read-frames ( seq -- assoc ) + [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline -: read-v2-header ( seq -- id3header ) +: read-v2-header ( seq -- header ) [
] dip { [ [ 3 5 ] dip >array >>version ] @@ -125,15 +147,18 @@ TUPLE: id3v1-info title artist album year comment genre ; [ [ 6 10 ] dip >28bitword >>size ] } cleave ; inline -: read-v2-tag-data ( seq -- id3v2-info ) - 10 cut-slice - [ read-v2-header ] - [ read-frames ] bi* ; inline - -: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline +: merge-frames ( id3 assoc -- id3 ) + [ dup frames>> ] dip update ; inline -: (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip +: merge-id3v1 ( id3 -- id3 ) + dup id3v1>frames frames>assoc merge-frames ; inline + +: read-v2-tags ( id3 seq -- id3 ) + 10 cut-slice + [ read-v2-header >>header ] + [ read-frames frames>assoc merge-frames ] bi* ; inline + +: extract-v1-tags ( id3 seq -- id3 ) { [ 30 head-slice decode-text filter-text-data >>title ] [ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ] @@ -143,8 +168,30 @@ TUPLE: id3v1-info title artist album year comment genre ; [ [ 124 ] dip nth number>string >>genre ] } cleave ; inline -: read-v1-tag-data ( seq -- mp3-file ) - skip-to-v1-data (read-v1-tag-data) ; inline +: read-v1-tags ( id3 seq -- id3 ) + id3v1-offset tail-slice* 3 tail-slice + extract-v1-tags ; inline + +: extract-v1+-tags ( id3 seq -- id3 ) + { + [ 60 head-slice decode-text filter-text-data [ append ] change-title ] + [ + [ 60 120 ] dip subseq decode-text filter-text-data + [ append ] change-artist + ] + [ + [ 120 180 ] dip subseq decode-text filter-text-data + [ append ] change-album + ] + [ [ 180 ] dip nth >>speed ] + [ [ 181 211 ] dip subseq decode-text >>genre-name ] + [ [ 211 217 ] dip subseq decode-text >>start-time ] + [ [ 217 223 ] dip subseq decode-text >>end-time ] + } cleave ; inline + +: read-v1+-tags ( id3 seq -- id3 ) + id3v1+-offset tail-slice* 4 tail-slice + extract-v1+-tags ; inline : parse-genre ( string -- n/f ) dup "(" ?head-slice drop ")" ?tail-slice drop @@ -154,34 +201,35 @@ TUPLE: id3v1-info title artist album year comment genre ; drop ] if ; inline -: (mp3>id3) ( path -- id3v2-info/f ) +: (mp3>id3) ( path -- id3v2/f ) [ + [ ] dip { - { [ dup id3v2? ] [ read-v2-tag-data ] } - { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] } - [ drop f ] - } cond + [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v2? [ read-v2-tags ] [ drop ] if ] + } cleave ] with-mapped-uchar-file ; PRIVATE> -: mp3>id3 ( path -- id3v2-info/f ) +: mp3>id3 ( path -- id3/f ) dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline : find-id3-frame ( id3 name -- obj/f ) swap frames>> at* [ data>> ] when ; inline -: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline +: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline -: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline +: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline -: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline +: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline -: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline +: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline -: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline +: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline -: genre ( id3 -- genre/f ) +: genre ( id3 -- string/f ) "TCON" find-id3-frame parse-genre ; inline : find-mp3s ( path -- seq ) From 6583b4d38e1c82baa1742fdd931b1e90b64a78a4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:28:48 -0500 Subject: [PATCH 16/56] rename html.parser.state to sequence-parser --- extra/c/preprocessor/preprocessor.factor | 2 +- extra/html/parser/parser.factor | 2 +- extra/html/parser/state/state-tests.factor | 104 -------------- extra/html/parser/state/state.factor | 127 ------------------ extra/html/parser/utils/utils.factor | 4 +- .../sequence-parser-tests.factor | 104 ++++++++++++++ extra/sequence-parser/sequence-parser.factor | 126 +++++++++++++++++ 7 files changed, 234 insertions(+), 235 deletions(-) delete mode 100644 extra/html/parser/state/state-tests.factor delete mode 100644 extra/html/parser/state/state.factor create mode 100644 extra/sequence-parser/sequence-parser-tests.factor create mode 100644 extra/sequence-parser/sequence-parser.factor diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f7cd10a0e9..e5029ca683 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: html.parser.state io io.encodings.utf8 io.files +USING: sequence-parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 61315a4925..b1dc4de4df 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables html.parser.state +USING: accessors arrays hashtables sequence-parser html.parser.utils kernel namespaces sequences unicode.case unicode.categories combinators.short-circuit quoting fry ; diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor deleted file mode 100644 index c8a8a95892..0000000000 --- a/extra/html/parser/state/state-tests.factor +++ /dev/null @@ -1,104 +0,0 @@ -USING: tools.test html.parser.state ascii kernel accessors ; -IN: html.parser.state.tests - -[ "hello" ] -[ "hello" [ take-rest ] state-parse ] unit-test - -[ "hi" " how are you?" ] -[ - "hi how are you?" - [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse -] unit-test - -[ "foo" ";bar" ] -[ - "foo;bar" [ - [ CHAR: ; take-until-object ] [ take-rest ] bi - ] state-parse -] unit-test - -[ "foo " " bar" ] -[ - "foo and bar" [ - [ "and" take-until-sequence ] [ take-rest ] bi - ] state-parse -] unit-test - -[ 6 ] -[ - " foo " [ skip-whitespace n>> ] state-parse -] unit-test - -[ { 1 2 } ] -[ { 1 2 3 } [ current 3 = ] take-until ] unit-test - -[ { 1 2 } ] -[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test - -[ "ab" ] -[ "abcd" "ab" take-sequence ] unit-test - -[ f ] -[ "abcd" "lol" take-sequence ] unit-test - -[ "ab" ] -[ - "abcd" - [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi -] unit-test - -[ "" ] -[ "abcd" "" take-sequence ] unit-test - -[ "cd" ] -[ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test - -[ f ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi -] unit-test - -[ "abc\\\"def" ] -[ - "\"abc\\\"def\" asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "asdf" ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ skip-whitespace "asdf" take-sequence ] bi -] unit-test - -[ f ] -[ - "\"abc asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "\"abc" ] -[ - "\"abc asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ "\"abc" take-sequence ] bi -] unit-test - -[ "c" ] -[ "c" take-token ] unit-test - -[ f ] -[ "" take-token ] unit-test - -[ "abcd e \\\"f g" ] -[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test - -[ "" ] -[ "" take-rest ] unit-test - -[ "" ] -[ "abc" dup "abc" take-sequence drop take-rest ] unit-test - -[ f ] -[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor deleted file mode 100644 index 2bcd08be5f..0000000000 --- a/extra/html/parser/state/state.factor +++ /dev/null @@ -1,127 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting ; - -IN: html.parser.state - -TUPLE: state-parser sequence n ; - -: ( sequence -- state-parser ) - state-parser new - swap >>sequence - 0 >>n ; - -: offset ( state-parser offset -- char/f ) - swap - [ n>> + ] [ sequence>> ?nth ] bi ; inline - -: current ( state-parser -- char/f ) 0 offset ; inline - -: previous ( state-parser -- char/f ) -1 offset ; inline - -: peek-next ( state-parser -- char/f ) 1 offset ; inline - -: advance ( state-parser -- state-parser ) - [ 1 + ] change-n ; inline - -: advance* ( state-parser -- ) - advance drop ; inline - -: get+increment ( state-parser -- char/f ) - [ current ] [ advance drop ] bi ; inline - -:: skip-until ( state-parser quot: ( obj -- ? ) -- ) - state-parser current [ - state-parser quot call [ state-parser advance quot skip-until ] unless - ] when ; inline recursive - -: state-parse-end? ( state-parser -- ? ) current not ; - -: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f ) - over state-parse-end? [ - 2drop f - ] [ - [ drop n>> ] - [ skip-until ] - [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq - ] if ; inline - -: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f ) - [ not ] compose take-until ; inline - -: ( from to seq -- slice/f ) - 3dup { - [ 2drop 0 < ] - [ [ drop ] 2dip length > ] - [ drop > ] - } 3|| [ 3drop f ] [ slice boa ] if ; inline - -:: take-sequence ( state-parser sequence -- obj/f ) - state-parser [ n>> dup sequence length + ] [ sequence>> ] bi - sequence sequence= [ - sequence - state-parser [ sequence length + ] change-n drop - ] [ - f - ] if ; - -:: take-until-sequence ( state-parser sequence -- sequence' ) - sequence length :> growing - state-parser - [ - current growing push-growing-circular - sequence growing sequence= - ] take-until :> found - found dup length - growing length 1- - head - state-parser advance drop ; - -: skip-whitespace ( state-parser -- state-parser ) - [ [ current blank? not ] take-until drop ] keep ; - -: take-rest-slice ( state-parser -- sequence/f ) - [ sequence>> ] [ n>> ] bi - 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline - -: take-rest ( state-parser -- sequence ) - [ take-rest-slice ] [ sequence>> like ] bi ; - -: take-until-object ( state-parser obj -- sequence ) - '[ current _ = ] take-until ; - -: state-parse ( sequence quot -- ) - [ ] dip call ; inline - -:: take-quoted-string ( state-parser escape-char quote-char -- string ) - state-parser n>> :> start-n - state-parser advance - [ - { - [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] - [ current quote-char = not ] - } 1|| - ] take-while :> string - state-parser current quote-char = [ - state-parser advance* string - ] [ - start-n state-parser (>>n) f - ] if ; - -: (take-token) ( state-parser -- string ) - skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; - -:: take-token* ( state-parser escape-char quote-char -- string/f ) - state-parser skip-whitespace - dup current { - { quote-char [ escape-char quote-char take-quoted-string ] } - { f [ drop f ] } - [ drop (take-token) ] - } case ; - -: take-token ( state-parser -- string/f ) - CHAR: \ CHAR: " take-token* ; - -: write-full ( state-parser -- ) sequence>> write ; -: write-rest ( state-parser -- ) take-rest write ; diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 7abd2fcdf7..afd63daf6b 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs circular combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint -quotations sequences splitting html.parser.state strings -combinators.short-circuit quoting ; +quotations sequences splitting strings quoting +combinators.short-circuit ; IN: html.parser.utils : trim1 ( seq ch -- newseq ) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor new file mode 100644 index 0000000000..915d119abe --- /dev/null +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -0,0 +1,104 @@ +USING: tools.test sequence-parser ascii kernel accessors ; +IN: sequence-parser.tests + +[ "hello" ] +[ "hello" [ take-rest ] parse-sequence ] unit-test + +[ "hi" " how are you?" ] +[ + "hi how are you?" + [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence +] unit-test + +[ "foo" ";bar" ] +[ + "foo;bar" [ + [ CHAR: ; take-until-object ] [ take-rest ] bi + ] parse-sequence +] unit-test + +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence ] [ take-rest ] bi + ] parse-sequence +] unit-test + +[ 6 ] +[ + " foo " [ skip-whitespace n>> ] parse-sequence +] unit-test + +[ { 1 2 } ] +[ { 1 2 3 } [ current 3 = ] take-until ] unit-test + +[ { 1 2 } ] +[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test + +[ "ab" ] +[ "abcd" "ab" take-sequence ] unit-test + +[ f ] +[ "abcd" "lol" take-sequence ] unit-test + +[ "ab" ] +[ + "abcd" + [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi +] unit-test + +[ "" ] +[ "abcd" "" take-sequence ] unit-test + +[ "cd" ] +[ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test + +[ f ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi +] unit-test + +[ "abc\\\"def" ] +[ + "\"abc\\\"def\" asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "asdf" ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ skip-whitespace "asdf" take-sequence ] bi +] unit-test + +[ f ] +[ + "\"abc asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "\"abc" ] +[ + "\"abc asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ "\"abc" take-sequence ] bi +] unit-test + +[ "c" ] +[ "c" take-token ] unit-test + +[ f ] +[ "" take-token ] unit-test + +[ "abcd e \\\"f g" ] +[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test + +[ "" ] +[ "" take-rest ] unit-test + +[ "" ] +[ "abc" dup "abc" take-sequence drop take-rest ] unit-test + +[ f ] +[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor new file mode 100644 index 0000000000..ad49982d88 --- /dev/null +++ b/extra/sequence-parser/sequence-parser.factor @@ -0,0 +1,126 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces math kernel sequences accessors fry circular +unicode.case unicode.categories locals combinators.short-circuit +make combinators io splitting ; +IN: sequence-parser + +TUPLE: sequence-parser sequence n ; + +: ( sequence -- sequence-parser ) + sequence-parser new + swap >>sequence + 0 >>n ; + +: offset ( sequence-parser offset -- char/f ) + swap + [ n>> + ] [ sequence>> ?nth ] bi ; inline + +: current ( sequence-parser -- char/f ) 0 offset ; inline + +: previous ( sequence-parser -- char/f ) -1 offset ; inline + +: peek-next ( sequence-parser -- char/f ) 1 offset ; inline + +: advance ( sequence-parser -- sequence-parser ) + [ 1 + ] change-n ; inline + +: advance* ( sequence-parser -- ) + advance drop ; inline + +: get+increment ( sequence-parser -- char/f ) + [ current ] [ advance drop ] bi ; inline + +:: skip-until ( sequence-parser quot: ( obj -- ? ) -- ) + sequence-parser current [ + sequence-parser quot call [ sequence-parser advance quot skip-until ] unless + ] when ; inline recursive + +: sequence-parse-end? ( sequence-parser -- ? ) current not ; + +: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) + over sequence-parse-end? [ + 2drop f + ] [ + [ drop n>> ] + [ skip-until ] + [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq + ] if ; inline + +: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) + [ not ] compose take-until ; inline + +: ( from to seq -- slice/f ) + 3dup { + [ 2drop 0 < ] + [ [ drop ] 2dip length > ] + [ drop > ] + } 3|| [ 3drop f ] [ slice boa ] if ; inline + +:: take-sequence ( sequence-parser sequence -- obj/f ) + sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi + sequence sequence= [ + sequence + sequence-parser [ sequence length + ] change-n drop + ] [ + f + ] if ; + +:: take-until-sequence ( sequence-parser sequence -- sequence' ) + sequence length :> growing + sequence-parser + [ + current growing push-growing-circular + sequence growing sequence= + ] take-until :> found + found dup length + growing length 1- - head + sequence-parser advance drop ; + +: skip-whitespace ( sequence-parser -- sequence-parser ) + [ [ current blank? not ] take-until drop ] keep ; + +: take-rest-slice ( sequence-parser -- sequence/f ) + [ sequence>> ] [ n>> ] bi + 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline + +: take-rest ( sequence-parser -- sequence ) + [ take-rest-slice ] [ sequence>> like ] bi ; + +: take-until-object ( sequence-parser obj -- sequence ) + '[ current _ = ] take-until ; + +: parse-sequence ( sequence quot -- ) + [ ] dip call ; inline + +:: take-quoted-string ( sequence-parser escape-char quote-char -- string ) + sequence-parser n>> :> start-n + sequence-parser advance + [ + { + [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] + [ current quote-char = not ] + } 1|| + ] take-while :> string + sequence-parser current quote-char = [ + sequence-parser advance* string + ] [ + start-n sequence-parser (>>n) f + ] if ; + +: (take-token) ( sequence-parser -- string ) + skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; + +:: take-token* ( sequence-parser escape-char quote-char -- string/f ) + sequence-parser skip-whitespace + dup current { + { quote-char [ escape-char quote-char take-quoted-string ] } + { f [ drop f ] } + [ drop (take-token) ] + } case ; + +: take-token ( sequence-parser -- string/f ) + CHAR: \ CHAR: " take-token* ; + +: write-full ( sequence-parser -- ) sequence>> write ; +: write-rest ( sequence-parser -- ) take-rest write ; From 47369e927c740bc6481b6da24b611965f7647b69 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:29:38 -0500 Subject: [PATCH 17/56] add a combinator to spider --- extra/spider/unique-deque/unique-deque.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor index ad46abdad3..b26797f8d5 100644 --- a/extra/spider/unique-deque/unique-deque.factor +++ b/extra/spider/unique-deque/unique-deque.factor @@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ; : pop-url ( unique-deque -- todo-url ) deque>> pop-front ; : peek-url ( unique-deque -- todo-url ) deque>> peek-front ; + +: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- ) + pick deque-empty? [ 3drop ] [ + [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ] + [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi + ] if ; inline recursive From d44c08bf68a7d31eab30e7981fdec483a280f3f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 18:23:05 -0500 Subject: [PATCH 18/56] write synchsafe numbers to sequences --- extra/id3/id3-tests.factor | 6 +++++- extra/id3/id3.factor | 12 ++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index a8f35e582c..9bb7558077 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 combinators ; +USING: tools.test id3 combinators grouping id3.private +sequences math ; IN: id3.tests : id3-params ( id3 -- title artist album year comment genre ) @@ -40,3 +41,6 @@ IN: id3.tests "Big Band" ] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test + +[ t ] +[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 8a235d305d..a742a1f08d 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search literals ; +io.directories.search literals math.functions ; IN: id3 array sift ; -: >28bitword ( seq -- int ) +: seq>synchsafe ( seq -- n ) 0 [ [ 7 shift ] dip bitor ] reduce ; inline +: synchsafe>seq ( n -- seq ) + dup 1+ log2 1+ 7 / ceiling + [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline + : filter-text-data ( data -- filtered ) [ printable? ] filter ; inline @@ -121,7 +125,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ ] dip { [ 4 head-slice decode-text >>tag ] - [ [ 4 8 ] dip subseq >28bitword >>size ] + [ [ 4 8 ] dip subseq seq>synchsafe >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] } cleave ; inline @@ -144,7 +148,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] { [ [ 3 5 ] dip >array >>version ] [ [ 5 ] dip nth >>flags ] - [ [ 6 10 ] dip >28bitword >>size ] + [ [ 6 10 ] dip seq>synchsafe >>size ] } cleave ; inline : merge-frames ( id3 assoc -- id3 ) From a6989d3087c849d8b8d9488b2710937ce17d48c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 19:50:25 -0500 Subject: [PATCH 19/56] fix bug in base64 -- would fail with bitor trying to OR f with an integer --- basis/base64/base64-tests.factor | 3 +++ basis/base64/base64.factor | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index ddefff35bb..572d8a5227 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -23,5 +23,8 @@ IN: base64.tests ascii encode >base64-lines >string ] unit-test +[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ] +[ malformed-base64? ] must-fail-with + \ >base64 must-infer \ base64> must-infer diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index c51d871bb5..111fe49f95 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -18,6 +18,8 @@ IN: base64 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; inline +ERROR: malformed-base64 ; + : base64>ch ( ch -- ch ) { f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f @@ -25,7 +27,7 @@ IN: base64 f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 - } nth ; inline + } nth [ malformed-base64 ] unless* ; inline SYMBOL: column @@ -48,8 +50,6 @@ SYMBOL: column [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline -ERROR: malformed-base64 ; - : decode4 ( seq -- ) [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ] [ [ CHAR: = = ] count ] bi head-slice* From a761d570198db662a0f0705a920d44d9c79dc8ba Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:03:18 -0500 Subject: [PATCH 20/56] improve sequence-parser --- .../sequence-parser-tests.factor | 44 +++++++++++++++++-- extra/sequence-parser/sequence-parser.factor | 39 +++++++++++++--- 2 files changed, 73 insertions(+), 10 deletions(-) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 915d119abe..715beae5da 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -17,13 +17,39 @@ IN: sequence-parser.tests ] parse-sequence ] unit-test -[ "foo " " bar" ] +[ "foo " "and bar" ] [ "foo and bar" [ [ "and" take-until-sequence ] [ take-rest ] bi ] parse-sequence ] unit-test +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence ] + [ "and" take-sequence drop ] + [ take-rest ] tri + ] parse-sequence +] unit-test + +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence* ] + [ take-rest ] bi + ] parse-sequence +] unit-test + +[ { 1 2 } ] +[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test + +[ f "aaaa" ] +[ + "aaaa" + [ "b" take-until-sequence ] [ take-rest ] bi +] unit-test + [ 6 ] [ " foo " [ skip-whitespace n>> ] parse-sequence @@ -32,9 +58,6 @@ IN: sequence-parser.tests [ { 1 2 } ] [ { 1 2 3 } [ current 3 = ] take-until ] unit-test -[ { 1 2 } ] -[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test - [ "ab" ] [ "abcd" "ab" take-sequence ] unit-test @@ -102,3 +125,16 @@ IN: sequence-parser.tests [ f ] [ "abc" "abcdefg" take-sequence ] unit-test + +[ 1234 ] +[ "1234f" take-integer ] unit-test + +[ "yes" ] +[ + "yes1234f" + [ take-integer drop ] [ "yes" take-sequence ] bi +] unit-test + +[ f ] [ "" 4 take-n ] unit-test +[ "abcd" ] [ "abcd" 4 take-n ] unit-test +[ "abcd" "efg" ] [ "abcdefg" [ 4 take-n ] [ take-rest ] bi ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index ad49982d88..22f133bf70 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting ; +make combinators io splitting math.parser ; IN: sequence-parser TUPLE: sequence-parser sequence n ; @@ -66,17 +66,33 @@ TUPLE: sequence-parser sequence n ; f ] if ; -:: take-until-sequence ( sequence-parser sequence -- sequence' ) +: take-sequence* ( sequence-parser sequence -- ) + take-sequence drop ; + +:: take-until-sequence ( sequence-parser sequence -- sequence'/f ) + sequence-parser n>> :> saved sequence length :> growing sequence-parser [ current growing push-growing-circular sequence growing sequence= ] take-until :> found - found dup length - growing length 1- - head - sequence-parser advance drop ; - + growing sequence sequence= [ + found dup length + growing length 1- - head + sequence-parser [ growing length - 1 + ] change-n drop + ! sequence-parser advance drop + ] [ + saved sequence-parser (>>n) + f + ] if ; + +:: take-until-sequence* ( sequence-parser sequence -- sequence'/f ) + sequence-parser sequence take-until-sequence :> out + out [ + sequence-parser [ sequence length + ] change-n drop + ] when out ; + : skip-whitespace ( sequence-parser -- sequence-parser ) [ [ current blank? not ] take-until drop ] keep ; @@ -122,5 +138,16 @@ TUPLE: sequence-parser sequence n ; : take-token ( sequence-parser -- string/f ) CHAR: \ CHAR: " take-token* ; +: take-integer ( sequence-parser -- n/f ) + [ current digit? ] take-while string>number ; + +:: take-n ( sequence-parser n -- seq/f ) + n sequence-parser [ n>> + ] [ sequence>> length ] bi > [ + f + ] [ + sequence-parser n>> dup n + sequence-parser sequence>> subseq + sequence-parser [ n + ] change-n drop + ] if ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From 2179b4bca13f794be09b7ab1345106d01dc44560 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:03:42 -0500 Subject: [PATCH 21/56] minor cleanup --- basis/tools/hexdump/hexdump.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 63b55729fb..666e051088 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -16,10 +16,11 @@ IN: tools.hexdump 16 * >hex 8 CHAR: 0 pad-head write "h: " write ; : >hex-digit ( digit -- str ) - >hex 2 CHAR: 0 pad-head " " append ; + >hex 2 CHAR: 0 pad-head ; : >hex-digits ( bytes -- str ) - [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ; + [ >hex-digit " " append ] { } map-as concat + 48 CHAR: \s pad-tail ; : >ascii ( bytes -- str ) [ [ printable? ] keep CHAR: . ? ] "" map-as ; From 732065d7759d5b5368948808a48d4185540c91c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:32:57 -0500 Subject: [PATCH 22/56] more work on sequence-parser --- .../sequence-parser-tests.factor | 12 ++++++++++++ extra/sequence-parser/sequence-parser.factor | 18 +++++++++++++++++- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 715beae5da..f6339b7127 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -138,3 +138,15 @@ IN: sequence-parser.tests [ f ] [ "" 4 take-n ] unit-test [ "abcd" ] [ "abcd" 4 take-n ] unit-test [ "abcd" "efg" ] [ "abcdefg" [ 4 take-n ] [ take-rest ] bi ] unit-test + +[ "asdfasdf" ] [ + "/*asdfasdf*/" take-c-comment +] unit-test + +[ "k" ] [ + "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "/*asdfasdf" ] [ + "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi +] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 22f133bf70..d5adc56800 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -12,6 +12,12 @@ TUPLE: sequence-parser sequence n ; swap >>sequence 0 >>n ; +:: with-sequence-parser ( sequence-parser quot -- seq/f ) + sequence-parser n>> :> n + sequence-parser quot call [ + n sequence-parser (>>n) f + ] unless* ; inline + : offset ( sequence-parser offset -- char/f ) swap [ n>> + ] [ sequence>> ?nth ] bi ; inline @@ -33,7 +39,8 @@ TUPLE: sequence-parser sequence n ; :: skip-until ( sequence-parser quot: ( obj -- ? ) -- ) sequence-parser current [ - sequence-parser quot call [ sequence-parser advance quot skip-until ] unless + sequence-parser quot call + [ sequence-parser advance quot skip-until ] unless ] when ; inline recursive : sequence-parse-end? ( sequence-parser -- ? ) current not ; @@ -149,5 +156,14 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ n + ] change-n drop ] if ; +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From a0ba66080d86a9aa624bdabd8c617d9337d2e9d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 03:52:53 -0500 Subject: [PATCH 23/56] Documentation updates suggested by dmpk2k --- basis/help/handbook/handbook.factor | 2 ++ core/classes/tuple/tuple-docs.factor | 10 +++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index b2a0e56c0a..0845264d61 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -49,6 +49,7 @@ $nl { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "boolean" { { $link t } " or " { $link f } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } + { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } } { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } } { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } } { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } @@ -56,6 +57,7 @@ $nl { "object" { "any datum which can be identified" } } { "ordering specifier" { "see " { $link "order-specifiers" } } } { "pathname string" { "an OS-specific pathname which identifies a file" } } + { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } } { "sequence" { "a sequence; see " { $link "sequence-protocol" } } } { "slot" { "a component of an object which can store a value" } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 32cab65904..d76faddf15 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors" $nl "Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." $nl -"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." +"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers." $nl "Examples of constructors:" { $code @@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples" " \"project manager\" >>position ;" } "An alternative strategy is to define the most general BOA constructor first:" { $code - ": ( name position -- person )" + ": ( name position -- employee )" " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code - ": ( name -- person )" - " \"manager\" ;" } + ": ( name -- employee )" + " \"manager\" ;" } "An example using reader words:" { $code "TUPLE: check to amount number ;" @@ -256,7 +256,7 @@ ARTICLE: "tuple-examples" "Tuple examples" ": next-position ( role -- newrole )" " positions [ index 1+ ] keep nth ;" "" - ": promote ( person -- person )" + ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" } From b11e0f60372ae13f7eea4f904d4781025fe644ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:01:59 -0500 Subject: [PATCH 24/56] assoc>query should not insert = if value is f. Reported by Chris Double --- basis/urls/encoding/encoding-tests.factor | 4 ++++ basis/urls/encoding/encoding.factor | 16 +++++++++++----- basis/urls/urls-tests.factor | 9 +++++++++ 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor index 87b1812ef8..78e31a764d 100644 --- a/basis/urls/encoding/encoding-tests.factor +++ b/basis/urls/encoding/encoding-tests.factor @@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test [ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +[ "a" ] [ { { "a" f } } assoc>query ] unit-test + +[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test \ No newline at end of file diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 7fed4b5f58..15b71ac0db 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -72,6 +72,15 @@ PRIVATE> ] when* ] 2keep set-at ; +: assoc-strings ( assoc -- assoc' ) + [ + { + { [ dup not ] [ ] } + { [ dup array? ] [ [ present ] map ] } + [ present 1array ] + } cond + ] assoc-map ; + PRIVATE> : query>assoc ( query -- assoc ) @@ -86,11 +95,8 @@ PRIVATE> : assoc>query ( assoc -- str ) [ - dup array? [ [ present ] map ] [ present 1array ] if - ] assoc-map - [ - [ + assoc-strings [ [ url-encode ] dip - [ url-encode "=" glue , ] with each + [ [ url-encode "=" glue , ] with each ] [ , ] if* ] assoc-each ] { } make "&" join ; diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index f45ad6449e..f2ecd6ec69 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -80,6 +80,15 @@ CONSTANT: urls } "ftp://slava:secret@ftp.kernel.org/" } + { + T{ url + { protocol "http" } + { host "foo.com" } + { path "/" } + { query H{ { "a" f } } } + } + "http://foo.com/?a" + } } urls [ From 2b26da1ad23f73c47f2182c846337677386d5674 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:03:06 -0500 Subject: [PATCH 25/56] Move images.normalization to extra since its not used for anything anymore --- {basis => extra}/images/normalization/authors.txt | 0 {basis => extra}/images/normalization/normalization.factor | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/images/normalization/authors.txt (100%) rename {basis => extra}/images/normalization/normalization.factor (100%) diff --git a/basis/images/normalization/authors.txt b/extra/images/normalization/authors.txt similarity index 100% rename from basis/images/normalization/authors.txt rename to extra/images/normalization/authors.txt diff --git a/basis/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor similarity index 100% rename from basis/images/normalization/normalization.factor rename to extra/images/normalization/normalization.factor From 713ab023379ab4b4cb229c97e10cd1d38e2cf73d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:18:29 -0500 Subject: [PATCH 26/56] Don't use GL_ARB_texture_non_power_of_two on ATI hardware to fix bug reported by Andy Turner and Caesar Hu --- basis/opengl/capabilities/capabilities.factor | 2 ++ basis/opengl/textures/textures.factor | 16 +++++++++++++--- basis/ui/gadgets/worlds/worlds.factor | 10 +++------- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index 09d49b33c2..ad04ce7fa5 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -32,6 +32,8 @@ IN: opengl.capabilities (gl-version) drop ; : gl-vendor-version ( -- version ) (gl-version) nip ; +: gl-vendor ( -- name ) + GL_VENDOR glGetString ; : has-gl-version? ( version -- ? ) gl-version version-before? ; : (make-gl-version-error) ( required-version -- ) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index a565a14597..76e0c473b9 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -1,13 +1,23 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel -opengl opengl.gl combinators images images.tesselation grouping -specialized-arrays.float sequences math math.vectors -math.matrices generalizations fry arrays namespaces ; +opengl opengl.gl opengl.capabilities combinators images +images.tesselation grouping specialized-arrays.float sequences math +math.vectors math.matrices generalizations fry arrays namespaces +system ; IN: opengl.textures SYMBOL: non-power-of-2-textures? +: check-extensions ( -- ) + #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly. + #! See thread 'Linux font display problem' April 2009 on Factor-talk + gl-vendor "ATI Technologies Inc." = not os macosx? or [ + "2.0" { "GL_ARB_texture_non_power_of_two" } + has-gl-version-or-extensions? + non-power-of-2-textures? set + ] when ; + : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index f671add531..a186de7670 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl opengl.capabilities opengl.textures sequences io -combinators combinators.short-circuit fry math.vectors math.rectangles -cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks +namespaces opengl opengl.textures sequences io combinators +combinators.short-circuit fry math.vectors math.rectangles cache +ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks ui.commands ; IN: ui.gadgets.worlds @@ -77,10 +77,6 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: check-extensions ( -- ) - "2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions? - non-power-of-2-textures? set ; - : (draw-world) ( world -- ) dup handle>> [ check-extensions From 370e90f57bc535a950d28091b41ff5197ecf7038 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:19:46 -0500 Subject: [PATCH 27/56] Fix odd race condition in ui.backend.cocoa --- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/ui/backend/cocoa/views/views.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index fc392c595d..1bbf46c69e 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -70,8 +70,8 @@ M:: cocoa-ui-backend (open-window) ( world -- ) world dim>> :> view view world world>NSRect :> window view -> release - window world window-loc>> auto-position world view register-window + window world window-loc>> auto-position world window save-position window install-window-delegate view window world (>>handle) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index b59848260d..602c9bec73 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -336,7 +336,7 @@ CLASS: { ! Initialization { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } - [ 2drop dup view-dim swap window (>>dim) yield ] + [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ] } { "doCommandBySelector:" "void" { "id" "SEL" "SEL" } From e2c858da3481213f7fd74ddfc9ed393bd47f608d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:20:23 -0500 Subject: [PATCH 28/56] Add better error check for 'window' word --- basis/ui/ui.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index dff7726d08..1de3912f28 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -12,7 +12,10 @@ IN: ui ! Assoc mapping aliens to gadgets SYMBOL: windows -: window ( handle -- world ) windows get-global at ; +ERROR: no-window handle ; + +: window ( handle -- world ) + windows get-global ?at [ no-window ] unless ; : window-focus ( handle -- gadget ) window world-focus ; From 509869ca70e08504045cf1cc0d0e2558d00eaa6a Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 10 Apr 2009 13:29:07 -0400 Subject: [PATCH 29/56] X11 UI: Fix resize flicker, exception when closing window, unsuccessful attempt at fixing raise-window --- basis/ui/backend/x11/x11.factor | 12 ++++++++++-- basis/ui/ui.factor | 7 ++----- basis/x11/windows/windows.factor | 6 ++---- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 422efbd188..5a2a8974e7 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -224,6 +224,10 @@ M: x-clipboard paste-clipboard [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip utf8 encode dup length XChangeProperty drop ; +: set-class ( dpy window -- ) + XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor" + utf8 encode dup length XChangeProperty drop ; + M: x11-ui-backend set-title ( string world -- ) handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; @@ -242,11 +246,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- ) M: x11-ui-backend (open-window) ( world -- ) dup gadget-window - handle>> window>> dup set-closable map-window ; + handle>> window>> + [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ; M: x11-ui-backend raise-window* ( world -- ) handle>> [ - dpy get swap window>> XRaiseWindow drop + dpy get swap window>> + [ RevertToPointerRoot CurrentTime XSetInputFocus drop ] + [ XRaiseWindow drop ] + 2bi ] when* ; M: x11-handle select-gl-context ( handle -- ) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 1de3912f28..8be486cb1a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -12,10 +12,7 @@ IN: ui ! Assoc mapping aliens to gadgets SYMBOL: windows -ERROR: no-window handle ; - -: window ( handle -- world ) - windows get-global ?at [ no-window ] unless ; +: window ( handle -- world ) windows get-global at ; : window-focus ( handle -- gadget ) window world-focus ; @@ -199,4 +196,4 @@ M: object close-window : with-ui ( quot -- ) ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ; -HOOK: beep ui-backend ( -- ) \ No newline at end of file +HOOK: beep ui-backend ( -- ) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 9619ae0bee..8085907bef 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -6,10 +6,10 @@ arrays fry ; IN: x11.windows : create-window-mask ( -- n ) - { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; + { CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) - dpy get root get rot XVisualInfo-visual AllocNone + [ dpy get root get ] dip XVisualInfo-visual AllocNone XCreateColormap ; : event-mask ( -- n ) @@ -29,8 +29,6 @@ IN: x11.windows : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" - 0 over set-XSetWindowAttributes-background_pixel - 0 over set-XSetWindowAttributes-border_pixel [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep event-mask over set-XSetWindowAttributes-event_mask ; From a10d490fe2e318de5d55038983474012933abdfc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 10 Apr 2009 17:50:05 -0500 Subject: [PATCH 30/56] more parsing work --- extra/c/preprocessor/preprocessor.factor | 68 +++++++++++-------- .../sequence-parser-tests.factor | 41 ++++++++++- extra/sequence-parser/sequence-parser.factor | 64 ++++++++++++++++- 3 files changed, 140 insertions(+), 33 deletions(-) diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index e5029ca683..f787befc31 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -41,7 +41,7 @@ ifs elifs elses ; DEFER: preprocess-file -ERROR: unknown-c-preprocessor state-parser name ; +ERROR: unknown-c-preprocessor sequence-parser name ; ERROR: bad-include-line line ; @@ -69,8 +69,16 @@ ERROR: header-file-missing path ; drop ] if ; -: handle-include ( preprocessor-state state-parser -- ) - skip-whitespace advance dup previous { +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: handle-include ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments advance dup previous { { CHAR: < [ CHAR: > take-until-object read-standard-include ] } { CHAR: " [ CHAR: " take-until-object read-local-include ] } [ bad-include-line ] @@ -81,58 +89,58 @@ ERROR: header-file-missing path ; : readlns ( -- string ) [ (readlns) ] { } make concat ; -: take-define-identifier ( state-parser -- string ) - skip-whitespace +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state state-parser -- ) +: handle-define ( preprocessor-state sequence-parser -- ) [ take-define-identifier ] - [ skip-whitespace take-rest ] bi + [ skip-whitespace/comments take-rest ] bi "\\" ?tail [ readlns append ] when spin symbol-table>> set-at ; -: handle-undef ( preprocessor-state state-parser -- ) +: handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; -: handle-ifdef ( preprocessor-state state-parser -- ) +: handle-ifdef ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip take-token over symbol-table>> key? [ drop ] [ t >>processing-disabled? drop ] if ; -: handle-ifndef ( preprocessor-state state-parser -- ) +: handle-ifndef ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip take-token over symbol-table>> key? [ t >>processing-disabled? drop ] [ drop ] if ; -: handle-endif ( preprocessor-state state-parser -- ) +: handle-endif ( preprocessor-state sequence-parser -- ) drop [ 1 - ] change-ifdef-nesting drop ; -: handle-if ( preprocessor-state state-parser -- ) +: handle-if ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip - skip-whitespace take-rest swap ifs>> push ; + skip-whitespace/comments take-rest swap ifs>> push ; -: handle-elif ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap elifs>> push ; +: handle-elif ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elifs>> push ; -: handle-else ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap elses>> push ; +: handle-else ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elses>> push ; -: handle-pragma ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap pragmas>> push ; +: handle-pragma ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap pragmas>> push ; -: handle-include-next ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap include-nexts>> push ; +: handle-include-next ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap include-nexts>> push ; -: handle-error ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap errors>> push ; +: handle-error ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap errors>> push ; ! nip take-rest throw ; -: handle-warning ( preprocessor-state state-parser -- ) - skip-whitespace +: handle-warning ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap warnings>> push ; -: parse-directive ( preprocessor-state state-parser string -- ) +: parse-directive ( preprocessor-state sequence-parser string -- ) { { "warning" [ handle-warning ] } { "error" [ handle-error ] } @@ -150,7 +158,7 @@ ERROR: header-file-missing path ; [ unknown-c-preprocessor ] } case ; -: parse-directive-line ( preprocessor-state state-parser -- ) +: parse-directive-line ( preprocessor-state sequence-parser -- ) advance dup take-token pick processing-disabled?>> [ "endif" = [ @@ -162,14 +170,14 @@ ERROR: header-file-missing path ; parse-directive ] if ; -: preprocess-line ( preprocessor-state state-parser -- ) - skip-whitespace dup current CHAR: # = +: preprocess-line ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments dup current CHAR: # = [ parse-directive-line ] [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ; : preprocess-lines ( preprocessor-state -- ) readln - [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] + [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] [ drop ] if* ; ERROR: include-nested-too-deeply ; diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index f6339b7127..3b2fcad5eb 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -126,7 +126,7 @@ IN: sequence-parser.tests [ f ] [ "abc" "abcdefg" take-sequence ] unit-test -[ 1234 ] +[ "1234" ] [ "1234f" take-integer ] unit-test [ "yes" ] @@ -147,6 +147,45 @@ IN: sequence-parser.tests "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi ] unit-test +[ "omg" ] [ + "//asdfasdf\nomg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + +[ "omg" ] [ + "omg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + [ "/*asdfasdf" ] [ "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi ] unit-test + +[ "asdf" "eoieoei" ] [ + "//asdf\neoieoei" + [ take-c++-comment ] [ take-rest ] bi +] unit-test + +[ f "33asdf" ] +[ "33asdf" [ take-c-identifier ] [ take-rest ] bi ] unit-test + +[ "asdf" ] +[ "asdf" take-c-identifier ] unit-test + +[ "_asdf" ] +[ "_asdf" take-c-identifier ] unit-test + +[ "_asdf400" ] +[ "_asdf400" take-c-identifier ] unit-test + +[ "123" ] +[ "123jjj" take-c-integer ] unit-test + +[ "123uLL" ] +[ "123uLL" take-c-integer ] unit-test + +[ "123ull" ] +[ "123ull" take-c-integer ] unit-test + +[ "123u" ] +[ "123u" take-c-integer ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index d5adc56800..4f57a7ccae 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting math.parser ; +make combinators io splitting math.parser math.ranges +generalizations sorting.functor math.order sorting.slots ; IN: sequence-parser TUPLE: sequence-parser sequence n ; @@ -146,7 +147,7 @@ TUPLE: sequence-parser sequence n ; CHAR: \ CHAR: " take-token* ; : take-integer ( sequence-parser -- n/f ) - [ current digit? ] take-while string>number ; + [ current digit? ] take-while ; :: take-n ( sequence-parser n -- seq/f ) n sequence-parser [ n>> + ] [ sequence>> length ] bi > [ @@ -165,5 +166,64 @@ TUPLE: sequence-parser sequence n ; ] if ] with-sequence-parser ; +: take-c++-comment ( sequence-parser -- seq/f ) + [ + dup "//" take-sequence [ + [ + [ + { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| + ] take-until + ] [ + advance drop + ] bi + ] [ + drop f + ] if + ] with-sequence-parser ; + +: c-identifier-begin? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + { CHAR: _ } 3append member? ; + +: c-identifier-ch? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 0 CHAR: 9 [a,b] + { CHAR: _ } 4 nappend member? ; + +: take-c-identifier ( state-parser -- string/f ) + [ + dup current c-identifier-begin? [ + [ current c-identifier-ch? ] take-while + ] [ + drop f + ] if + ] with-sequence-parser ; + +<< "length" [ length ] define-sorting >> + +: sort-tokens ( seq -- seq' ) + { length>=< <=> } sort-by ; + +: take-first-matching ( state-parser seq -- seq ) + swap + '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ; + + +: take-longest ( state-parser seq -- seq ) + sort-tokens take-first-matching ; + +: take-c-integer ( state-parser -- string/f ) + [ + dup take-integer [ + swap + { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" } + take-longest [ append ] when* + ] [ + drop f + ] if* + ] with-sequence-parser ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From cd2ce4c9ae57c3257706ddb5b0cb6b576fed5849 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 09:03:00 -0500 Subject: [PATCH 31/56] fix blob selects in db.tuples --- basis/db/queries/queries.factor | 5 ++++- basis/db/tuples/tuples-tests.factor | 19 +++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 2730340bfc..c4aa47d383 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random strings math.parser math.intervals combinators math.bitwise nmake db db.tuples db.types classes words shuffle arrays destructors continuations db.tuples.private prettyprint -db.private ; +db.private byte-arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -115,6 +115,9 @@ M: sequence where ( spec obj -- ) [ " or " 0% ] [ dupd where ] interleave drop ] in-parens ; +M: byte-array where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + M: NULL where ( spec obj -- ) drop column-name>> 0% " is NULL" 0% ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 50d7f044d1..d4a58fa4fc 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO" [ test-compound-primary-key ] test-sqlite [ test-compound-primary-key ] test-postgresql + + +TUPLE: example id data ; + +example "EXAMPLE" +{ + { "id" "ID" +db-assigned-id+ } + { "data" "DATA" BLOB } +} define-persistent + +: test-blob-select ( -- ) + example ensure-table + [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test + [ + T{ example { id 1 } { data B{ 1 2 3 4 5 } } } + ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ; + +[ test-blob-select ] test-sqlite +[ test-blob-select ] test-postgresql From 9ac2214b627636762c28b9edbf50ca8c1be8e20a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 12:11:00 -0500 Subject: [PATCH 32/56] fix html.parser --- extra/html/parser/parser.factor | 44 ++++++++++++++++----------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index b1dc4de4df..d95c79dd88 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -37,89 +37,89 @@ SYMBOL: tagstack swap >>name swap >>text ; inline -: (read-quote) ( state-parser ch -- string ) +: (read-quote) ( sequence-parser ch -- string ) '[ [ current _ = ] take-until ] [ advance drop ] bi ; -: read-single-quote ( state-parser -- string ) +: read-single-quote ( sequence-parser -- string ) CHAR: ' (read-quote) ; -: read-double-quote ( state-parser -- string ) +: read-double-quote ( sequence-parser -- string ) CHAR: " (read-quote) ; -: read-quote ( state-parser -- string ) +: read-quote ( sequence-parser -- string ) dup get+increment CHAR: ' = [ read-single-quote ] [ read-double-quote ] if ; -: read-key ( state-parser -- string ) +: read-key ( sequence-parser -- string ) skip-whitespace [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; -: read-token ( state-parser -- string ) +: read-token ( sequence-parser -- string ) [ current blank? ] take-until ; -: read-value ( state-parser -- string ) +: read-value ( sequence-parser -- string ) skip-whitespace dup current quote? [ read-quote ] [ read-token ] if [ blank? ] trim ; -: read-comment ( state-parser -- ) +: read-comment ( sequence-parser -- ) "-->" take-until-sequence comment new-tag push-tag ; -: read-dtd ( state-parser -- ) +: read-dtd ( sequence-parser -- ) ">" take-until-sequence dtd new-tag push-tag ; -: read-bang ( state-parser -- ) +: read-bang ( sequence-parser -- ) advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [ advance advance read-comment ] [ read-dtd ] if ; -: read-tag ( state-parser -- string ) +: read-tag ( sequence-parser -- string ) [ [ current "><" member? ] take-until ] [ dup current CHAR: < = [ advance ] unless drop ] bi ; -: read-until-< ( state-parser -- string ) +: read-until-< ( sequence-parser -- string ) [ current CHAR: < = ] take-until ; -: parse-text ( state-parser -- ) +: parse-text ( sequence-parser -- ) read-until-< [ text new-tag push-tag ] unless-empty ; -: parse-key/value ( state-parser -- key value ) +: parse-key/value ( sequence-parser -- key value ) [ read-key >lower ] [ skip-whitespace "=" take-sequence ] [ swap [ read-value ] [ drop dup ] if ] tri ; -: (parse-attributes) ( state-parser -- ) +: (parse-attributes) ( sequence-parser -- ) skip-whitespace - dup state-parse-end? [ + dup sequence-parse-end? [ drop ] [ [ parse-key/value swap set ] [ (parse-attributes) ] bi ] if ; -: parse-attributes ( state-parser -- hashtable ) +: parse-attributes ( sequence-parser -- hashtable ) [ (parse-attributes) ] H{ } make-assoc ; : (parse-tag) ( string -- string' hashtable ) [ [ read-token >lower ] [ parse-attributes ] bi - ] state-parse ; + ] parse-sequence ; -: read-< ( state-parser -- string/f ) +: read-< ( sequence-parser -- string/f ) advance dup current [ CHAR: ! = [ read-bang f ] [ read-tag ] if ] [ drop f ] if* ; -: parse-tag ( state-parser -- ) +: parse-tag ( sequence-parser -- ) read-< [ (parse-tag) make-tag push-tag ] unless-empty ; -: (parse-html) ( state-parser -- ) +: (parse-html) ( sequence-parser -- ) dup peek-next [ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri ] [ drop ] if ; : tag-parse ( quot -- vector ) - V{ } clone tagstack [ state-parse ] with-variable ; inline + V{ } clone tagstack [ parse-sequence ] with-variable ; inline PRIVATE> From 7f80b52619e9f255e486cc913942a8efcd91bb95 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 12:12:09 -0500 Subject: [PATCH 33/56] fix base64 --- basis/base64/base64.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 111fe49f95..47147fa306 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces sequences strings io.crlf ; IN: base64 +ERROR: malformed-base64 ; + ch ( ch -- ch ) { f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f From ef095f5eef97a3592f883dec9a03e268ee8f4944 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 11 Apr 2009 14:28:48 -0500 Subject: [PATCH 34/56] Check return value of fread and fwrite in image.c --- vm/image.c | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/vm/image.c b/vm/image.c index 5ce7147200..a1987180d0 100755 --- a/vm/image.c +++ b/vm/image.c @@ -86,7 +86,8 @@ void load_image(F_PARAMETERS *p) } F_HEADER h; - fread(&h,sizeof(F_HEADER),1,file); + if(fread(&h,sizeof(F_HEADER),1,file) != 1) + fatal_error("Cannot read image header",0); if(h.magic != IMAGE_MAGIC) fatal_error("Bad image: magic number check failed",h.magic); @@ -145,27 +146,19 @@ bool save_image(const F_CHAR *filename) h.userenv[i] = userenv[i]; } - fwrite(&h,sizeof(F_HEADER),1,file); + bool ok = true; - if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) + if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false; + if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false; + if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false; + if(fclose(file)) ok = false; + + if(!ok) { - print_string("Save data heap failed: "); print_string(strerror(errno)); nl(); - return false; + print_string("save-image failed: "); print_string(strerror(errno)); nl(); } - if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) - { - print_string("Save code heap failed: "); print_string(strerror(errno)); nl(); - return false; - } - - if(fclose(file)) - { - print_string("Failed to close image file: "); print_string(strerror(errno)); nl(); - return false; - } - - return true; + return ok; } void primitive_save_image(void) From db3818814dc9d76f365ba2a39113dddf6287de4c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 11 Apr 2009 15:17:08 -0500 Subject: [PATCH 35/56] Refactor GLU usages in basis, and move opengl.glu to extra, and don't like VM with GLU --- basis/opengl/authors.txt | 1 + basis/opengl/gl/authors.txt | 2 +- basis/opengl/glu/authors.txt | 1 - basis/opengl/opengl.factor | 24 +++++++++++++++++------- basis/ui/render/render.factor | 4 ++-- extra/4DNav/camera/camera.factor | 2 +- extra/opengl/glu/authors.txt | 1 + {basis => extra}/opengl/glu/glu.factor | 14 +++++++++++++- {basis => extra}/opengl/glu/summary.txt | 0 {basis => extra}/opengl/glu/tags.txt | 0 vm/Config.unix | 2 +- 11 files changed, 37 insertions(+), 14 deletions(-) delete mode 100644 basis/opengl/glu/authors.txt create mode 100644 extra/opengl/glu/authors.txt rename {basis => extra}/opengl/glu/glu.factor (97%) rename {basis => extra}/opengl/glu/summary.txt (100%) rename {basis => extra}/opengl/glu/tags.txt (100%) diff --git a/basis/opengl/authors.txt b/basis/opengl/authors.txt index 55ac3c728e..f4e25322b8 100644 --- a/basis/opengl/authors.txt +++ b/basis/opengl/authors.txt @@ -1,3 +1,4 @@ Slava Pestov Eduardo Cavazos Joe Groff +Alex Chapman diff --git a/basis/opengl/gl/authors.txt b/basis/opengl/gl/authors.txt index 1901f27a24..e9c193bac7 100644 --- a/basis/opengl/gl/authors.txt +++ b/basis/opengl/gl/authors.txt @@ -1 +1 @@ -Slava Pestov +Alex Chapman diff --git a/basis/opengl/glu/authors.txt b/basis/opengl/glu/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/opengl/glu/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index c60917b42a..72ca8b8cdb 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -3,7 +3,7 @@ ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros -namespaces math.vectors math.parser opengl.gl opengl.glu combinators +namespaces math.vectors math.parser opengl.gl combinators combinators.smart arrays sequences splitting words byte-arrays assocs colors colors.constants accessors generalizations locals fry specialized-arrays.float specialized-arrays.uint ; @@ -16,10 +16,23 @@ IN: opengl : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; +: error>string ( n -- string ) + H{ + { HEX: 0 "No error" } + { HEX: 0501 "Invalid value" } + { HEX: 0500 "Invalid enumerant" } + { HEX: 0502 "Invalid operation" } + { HEX: 0503 "Stack overflow" } + { HEX: 0504 "Stack underflow" } + { HEX: 0505 "Out of memory" } + } at "Unknown error" or ; + +TUPLE: gl-error code string ; + : gl-error ( -- ) - glGetError dup zero? [ - "GL error: " over gluErrorString append throw - ] unless drop ; + glGetError dup 0 = [ drop ] [ + dup error>string \ gl-error boa throw + ] if ; : do-enabled ( what quot -- ) over glEnable dip glDisable ; inline @@ -151,9 +164,6 @@ MACRO: all-enabled-client-state ( seq quot -- ) MACRO: set-draw-buffers ( buffers -- ) words>values '[ _ (set-draw-buffers) ] ; -: gl-look-at ( eye focus up -- ) - [ first3 ] tri@ gluLookAt ; - : gen-dlist ( -- id ) 1 glGenLists ; : make-dlist ( type quot -- id ) diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 09c26fd271..c4e6f56886 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math.rectangles math.vectors namespaces kernel accessors -assocs combinators sequences opengl opengl.gl opengl.glu colors +assocs combinators sequences opengl opengl.gl colors colors.constants ui.gadgets ui.pens ; IN: ui.render @@ -22,7 +22,7 @@ SYMBOL: viewport-translation dim>> [ { 0 1 } v* viewport-translation set ] [ [ { 0 0 } ] dip gl-viewport ] - [ [ 0 ] dip first2 0 gluOrtho2D ] tri + [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri ] [ clip set ] bi do-clip ; diff --git a/extra/4DNav/camera/camera.factor b/extra/4DNav/camera/camera.factor index 1f36a46275..0d46d73f55 100755 --- a/extra/4DNav/camera/camera.factor +++ b/extra/4DNav/camera/camera.factor @@ -1,4 +1,4 @@ -USING: kernel namespaces math.vectors opengl 4DNav.turtle ; +USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ; IN: 4DNav.camera diff --git a/extra/opengl/glu/authors.txt b/extra/opengl/glu/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/opengl/glu/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/basis/opengl/glu/glu.factor b/extra/opengl/glu/glu.factor similarity index 97% rename from basis/opengl/glu/glu.factor rename to extra/opengl/glu/glu.factor index d603724a55..fe060e3553 100644 --- a/basis/opengl/glu/glu.factor +++ b/extra/opengl/glu/glu.factor @@ -1,8 +1,17 @@ ! Copyright (C) 2005 Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel sequences words ; +USING: alien alien.libraries alien.syntax kernel sequences words system +combinators ; IN: opengl.glu +os { + { [ dup macosx? ] [ drop ] } + { [ dup windows? ] [ drop ] } + { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] } +} cond + +LIBRARY: glu + ! These are defined as structs in glu.h, but we only ever use pointers to them TYPEDEF: void* GLUnurbs* TYPEDEF: void* GLUquadric* @@ -253,3 +262,6 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo ! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ; ! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ; ! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ; + +: gl-look-at ( eye focus up -- ) + [ first3 ] tri@ gluLookAt ; \ No newline at end of file diff --git a/basis/opengl/glu/summary.txt b/extra/opengl/glu/summary.txt similarity index 100% rename from basis/opengl/glu/summary.txt rename to extra/opengl/glu/summary.txt diff --git a/basis/opengl/glu/tags.txt b/extra/opengl/glu/tags.txt similarity index 100% rename from basis/opengl/glu/tags.txt rename to extra/opengl/glu/tags.txt diff --git a/vm/Config.unix b/vm/Config.unix index 339c3c3ffb..1f48847542 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -14,7 +14,7 @@ PLAF_EXE_OBJS += vm/main-unix.o ifdef NO_UI X11_UI_LIBS = else - X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lGLU -lX11 + X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11 endif # CFLAGS += -fPIC From 0fda643ab1e35c43a9b94b67f0138e9499c3f72e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 11 Apr 2009 20:30:51 -0500 Subject: [PATCH 36/56] Optimizing string>number --- basis/hints/hints.factor | 4 +- .../transforms/transforms.factor | 86 ++++++++++++------- core/math/parser/parser-tests.factor | 10 +-- core/math/parser/parser.factor | 74 ++++++++-------- 4 files changed, 103 insertions(+), 71 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 2534e0121f..d44bf92bf4 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -3,7 +3,7 @@ USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting -math generic generic.standard generic.standard.engines classes +math math.parser generic generic.standard generic.standard.engines classes hashtables ; IN: hints @@ -118,6 +118,8 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop +\ base> { string fixnum } "specializer" set-word-prop + M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..dfa46be7e2 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations assocs -combinators combinators.short-circuit classes.tuple +words sequences generic math math.order namespaces make quotations +assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals -generalizations stack-checker.backend stack-checker.state -stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +sequences.private generalizations stack-checker.backend +stack-checker.state stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms : give-up-transform ( word -- ) @@ -106,40 +106,68 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform -! Membership testing -CONSTANT: bit-member-max 256 +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 -: bit-member? ( seq -- ? ) +: lookup-table-at? ( assoc -- ? ) #! Can we use a fast byte array test here? { - [ length 4 > ] - [ [ integer? ] all? ] - [ [ 0 bit-member-max between? ] any? ] + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] } 1&& ; -: bit-member-seq ( seq -- flags ) - [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; -: bit-member-quot ( seq -- newquot ) - bit-member-seq +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq '[ - _ { - { [ over fixnum? ] [ ?nth 1 eq? ] } - { [ over bignum? ] [ ?nth 1 eq? ] } - [ 2drop f ] - } cond + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if ] ; -: member-quot ( seq -- newquot ) - dup bit-member? [ - bit-member-quot - ] [ - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot ] [ - unique [ key? ] curry + lookup-table-quot ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-transform + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry ] if ; \ member? [ @@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256 \ shuffle [ shuffle-mapping nths-quot -] 1 define-transform \ No newline at end of file +] 1 define-transform diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 0fb2559854..c655965e35 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,17 +95,17 @@ unit-test [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail -[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test +[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test -[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test +[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test -[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test +[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test [ t ] [ "0/0." string>number fp-nan? ] unit-test -[ 1.0/0.0 ] [ "1/0." string>number ] unit-test +[ 1/0. ] [ "1/0." string>number ] unit-test -[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test +[ -1/0. ] [ "-1/0." string>number ] unit-test [ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0d8f0c0b08..0a637c2eab 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private namespaces sequences strings -arrays combinators splitting math assocs make ; +USING: kernel math.private namespaces sequences sequences.private +strings arrays combinators splitting math assocs make ; IN: math.parser : digit> ( ch -- n ) @@ -28,13 +28,19 @@ IN: math.parser { CHAR: d 13 } { CHAR: e 14 } { CHAR: f 15 } - } at ; + } at 255 or ; inline : string>digits ( str -- digits ) - [ digit> ] { } map-as ; + [ digit> ] B{ } map-as ; inline -: digits>integer ( seq radix -- n ) - 0 swap [ swapd * + ] curry reduce ; +: (digits>integer) ( valid? accum digit radix -- valid? accum ) + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + +: each-digit ( seq radix quot -- n/f ) + [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline + +: digits>integer ( seq radix -- n/f ) + [ (digits>integer) ] each-digit ; inline DEFER: base> @@ -43,6 +49,9 @@ DEFER: base> SYMBOL: radix SYMBOL: negative? +: string>natural ( seq radix -- n/f ) + [ [ digit> ] dip (digits>integer) ] each-digit ; inline + : sign ( -- str ) negative? get "-" "+" ? ; : with-radix ( radix quot -- ) @@ -54,37 +63,30 @@ SYMBOL: negative? sign split1 [ (base>) ] dip dup [ (base>) ] [ drop 0 swap ] if ; -: string>ratio ( str -- a/b ) - "-" ?head dup negative? set swap - "/" split1 (base>) [ whole-part ] dip - 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; +: string>ratio ( str radix -- a/b ) + [ + "-" ?head dup negative? set swap + "/" split1 (base>) [ whole-part ] dip + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if + ] with-radix ; -: valid-digits? ( seq -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ f over memq? ] [ drop f ] } - [ radix get [ < ] curry all? ] - } cond ; - -: string>integer ( str -- n/f ) - "-" ?head swap - string>digits dup valid-digits? - [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; +: string>integer ( str radix -- n/f ) + over first-unsafe CHAR: - = [ + [ rest-slice ] dip string>natural dup [ neg ] when + ] [ + string>natural + ] if ; inline PRIVATE> : base> ( str radix -- n/f ) - [ - CHAR: / over member? [ - string>ratio - ] [ - CHAR: . over member? [ - string>float - ] [ - string>integer - ] if - ] if - ] with-radix ; + over empty? [ 2drop f ] [ + over [ "/." member? ] find nip { + { CHAR: / [ string>ratio ] } + { CHAR: . [ drop string>float ] } + [ drop string>integer ] + } case + ] if ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -147,9 +149,9 @@ M: ratio >base M: float >base drop { - { [ dup fp-nan? ] [ drop "0.0/0.0" ] } - { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } - { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } + { [ dup fp-nan? ] [ drop "0/0." ] } + { [ dup 1/0. = ] [ drop "1/0." ] } + { [ dup -1/0. = ] [ drop "-1/0." ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } [ float>string fix-float ] } cond ; From 541ce3aa6823f23d46e6b3aa9ccd9e38d3d2463f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 12 Apr 2009 13:57:49 -0500 Subject: [PATCH 37/56] Fixing regexp parser bug: now R/ foo/5 makes an error --- basis/regexp/parser/parser.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 9fcadc4008..70281aa798 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -102,8 +102,10 @@ MEMO: simple-category-table ( -- table ) { CHAR: s dotall } } ; +ERROR: nonexistent-option name ; + : ch>option ( ch -- singleton ) - options-assoc at ; + dup options-assoc at [ ] [ nonexistent-option ] ?if ; : option>ch ( option -- string ) options-assoc value-at ; From 85d595d8b68635cf8ba884847db92aab6a444a21 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 9 Apr 2009 00:04:42 -0300 Subject: [PATCH 38/56] irc.client: Big refactor --- extra/irc/client/base/base.factor | 37 ++ extra/irc/client/chats/chats-docs.factor | 20 + extra/irc/client/chats/chats.factor | 50 +++ extra/irc/client/client-docs.factor | 18 +- extra/irc/client/client.factor | 381 +----------------- .../internals-tests.factor} | 147 +++---- extra/irc/client/internals/internals.factor | 162 ++++++++ .../client/participants/participants.factor | 55 +++ extra/irc/messages/messages.factor | 11 +- 9 files changed, 410 insertions(+), 471 deletions(-) create mode 100644 extra/irc/client/base/base.factor create mode 100644 extra/irc/client/chats/chats-docs.factor create mode 100644 extra/irc/client/chats/chats.factor rename extra/irc/client/{client-tests.factor => internals/internals-tests.factor} (57%) create mode 100644 extra/irc/client/internals/internals.factor create mode 100644 extra/irc/client/participants/participants.factor diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor new file mode 100644 index 0000000000..f54e18ac4b --- /dev/null +++ b/extra/irc/client/base/base.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs concurrency.mailboxes io kernel namespaces +strings words.symbol irc.client.chats irc.messages ; +EXCLUDE: sequences => join ; +IN: irc.client.base + +SYMBOL: current-irc-client + +: irc> ( -- irc-client ) current-irc-client get ; +: stream> ( -- stream ) irc> stream>> ; +: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; +: chats> ( -- seq ) irc> chats>> values ; +: me? ( string -- ? ) irc> nick>> = ; + +: with-irc ( irc-client quot: ( -- ) -- ) + \ current-irc-client swap with-variable ; inline + +UNION: to-target privmsg notice ; +UNION: to-channel join part topic kick rpl-channel-modes + rpl-notopic rpl-topic rpl-names rpl-names-end ; +UNION: to-one-chat to-target to-channel mode ; +UNION: to-many-chats nick quit ; +UNION: to-all-chats irc-end irc-disconnected irc-connected ; +PREDICATE: to-me < to-target target>> me? ; + +GENERIC: chat-name ( irc-message -- name ) +M: mode chat-name name>> ; +M: to-target chat-name target>> ; +M: to-me chat-name sender>> ; +M: to-channel chat-name channel>> ; + +GENERIC: chat> ( obj -- chat/f ) +M: string chat> irc> chats>> at ; +M: symbol chat> irc> chats>> at ; +M: to-one-chat chat> chat-name +server-chat+ or chat> ; diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor new file mode 100644 index 0000000000..66fd1a207d --- /dev/null +++ b/extra/irc/client/chats/chats-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax quotations kernel ; +IN: irc.client.chats + +HELP: irc-client "IRC Client object" ; + +HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; + +HELP: irc-channel-chat "Chat for irc channels" ; + +HELP: irc-nick-chat "Chat for irc users" ; + +HELP: irc-profile "IRC Client profile object" ; + +HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ; + +HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ; + +HELP: irc-disconnected "Message sent to notify chats that connection was lost." ; + +HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ; diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor new file mode 100644 index 0000000000..7910afb22a --- /dev/null +++ b/extra/irc/client/chats/chats.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit +destructors arrays sequences ; +IN: irc.client.chats + +CONSTANT: irc-port 6667 ! Default irc port + +TUPLE: irc-chat in-messages client ; +TUPLE: irc-server-chat < irc-chat ; +TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ; +TUPLE: irc-nick-chat < irc-chat name ; +SYMBOL: +server-chat+ + +: ( -- irc-server-chat ) + irc-server-chat new + >>in-messages ; + +: ( name -- irc-channel-chat ) + irc-channel-chat new + swap >>name + >>in-messages + f >>password + H{ } clone >>participants + t >>clear-participants ; + +: ( name -- irc-nick-chat ) + irc-nick-chat new + swap >>name + >>in-messages ; + +TUPLE: irc-profile server port nickname password ; +C: irc-profile + +TUPLE: irc-client profile stream in-messages out-messages + chats is-running nick connect reconnect-time is-ready + exceptions ; + +: ( profile -- irc-client ) + dup nickname>> irc-client new + swap >>nick + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + 15 seconds >>reconnect-time + V{ } clone >>exceptions + [ latin1 ] >>connect ; + +SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index d95d2bc2c6..ad674cb0c1 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,16 +1,7 @@ -USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; +USING: help.markup help.syntax quotations kernel +irc.messages irc.messages.base irc.messages.parser irc.client.chats ; IN: irc.client -HELP: irc-client "IRC Client object" ; - -HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; - -HELP: irc-channel-chat "Chat for irc channels" ; - -HELP: irc-nick-chat "Chat for irc users" ; - -HELP: irc-profile "IRC Client profile object" ; - HELP: connect-irc "Connecting to an irc server" { $values { "irc-client" "an irc client object" } } { $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; @@ -69,6 +60,7 @@ ARTICLE: "irc.client" "IRC Client" { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } } + { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table @@ -79,7 +71,7 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Example:" } { $code - "USING: irc.client ;" + "USING: irc.client irc.client.chats ;" "SYMBOL: bot" "SYMBOL: mychannel" "! Create the profile and client objects" @@ -91,7 +83,7 @@ ARTICLE: "irc.client" "IRC Client" "! Register and start chat (this joins the channel)" "mychannel get bot get attach-chat" "! Send a message to the channel" - "\"what's up?\" mychannel get speak" + "\"Hello World!\" mychannel get speak" "! Read a message from the channel" "mychannel get hear" } diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index f2d671e30d..ae48d3ac4e 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -1,380 +1,15 @@ ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar - accessors destructors namespaces io assocs arrays fry - continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser ; -RENAME: join sequences => sjoin -EXCLUDE: sequences => join ; +USING: accessors concurrency.mailboxes destructors +irc.client.base irc.client.chats irc.client.internals kernel +namespaces sequences ; IN: irc.client -! ====================================== -! Setup and running objects -! ====================================== - -CONSTANT: irc-port 6667 ! Default irc port - -TUPLE: irc-profile server port nickname password ; -C: irc-profile - -TUPLE: irc-client profile stream in-messages out-messages - chats is-running nick connect reconnect-time is-ready ; - -: ( profile -- irc-client ) - irc-client new - swap >>profile - >>in-messages - >>out-messages - H{ } clone >>chats - dup profile>> nickname>> >>nick - [ latin1 ] >>connect - 15 seconds >>reconnect-time ; - -TUPLE: irc-chat in-messages client ; -TUPLE: irc-server-chat < irc-chat ; -TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ; -TUPLE: irc-nick-chat < irc-chat name ; -SYMBOL: +server-chat+ - -! participant modes -SYMBOL: +operator+ -SYMBOL: +voice+ -SYMBOL: +normal+ - -: participant-mode ( n -- mode ) - H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; - -! participant changed actions -SYMBOL: +join+ -SYMBOL: +part+ -SYMBOL: +mode+ -SYMBOL: +nick+ - -! chat objects -: ( -- irc-server-chat ) - f irc-server-chat boa ; - -: ( name -- irc-channel-chat ) - [ f ] dip f 60 seconds H{ } clone t - irc-channel-chat boa ; - -: ( name -- irc-nick-chat ) - [ f ] dip irc-nick-chat boa ; - -! ====================================== -! Message objects -! ====================================== - -TUPLE: participant-changed nick action parameter ; -C: participant-changed - -SINGLETON: irc-chat-end ! sent to a chat 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 - -: terminate-irc ( irc-client -- ) - dup is-running>> [ - f >>is-running - [ stream>> dispose ] keep - [ in-messages>> ] [ out-messages>> ] bi 2array - [ irc-end swap mailbox-put ] each - ] [ drop ] if ; - - ( -- irc-client ) current-irc-client get ; -: irc-write ( s -- ) irc> stream>> stream-write ; -: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ; -: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; -: chat> ( name -- chat/f ) irc> chats>> at ; -: channel-mode? ( mode -- ? ) name>> first "#&" member? ; -: me? ( string -- ? ) irc> nick>> = ; - -GENERIC: to-chat ( message obj -- ) - -M: string to-chat - chat> [ +server-chat+ chat> ] unless* - [ to-chat ] [ drop ] if* ; - -M: irc-chat to-chat in-messages>> mailbox-put ; -M: sequence to-chat [ to-chat ] with each ; - -: unregister-chat ( name -- ) - irc> chats>> - [ at [ irc-chat-end ] dip to-chat ] - [ delete-at ] - 2bi ; - -: (remove-participant) ( nick chat -- ) - [ participants>> delete-at ] - [ [ +part+ f ] dip to-chat ] 2bi ; - -: remove-participant ( nick channel -- ) - chat> [ (remove-participant) ] [ drop ] if* ; - -: chats-with-participant ( nick -- seq ) - irc> chats>> values - [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] - with filter ; - -: remove-participant-from-all ( nick -- ) - dup chats-with-participant [ (remove-participant) ] with each ; - -: notify-rename ( newnick oldnick chat -- ) - [ participant-changed new +nick+ >>action - [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ; - -: rename-participant ( newnick oldnick chat -- ) - [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ] - [ notify-rename ] 3bi ; - -: rename-participant-in-all ( oldnick newnick -- ) - swap dup chats-with-participant [ rename-participant ] with with each ; - -: add-participant ( mode nick channel -- ) - chat> - [ participants>> set-at ] - [ [ +join+ f ] dip to-chat ] 2bi ; - -: change-participant-mode ( channel mode nick -- ) - rot chat> - [ participants>> set-at ] - [ [ participant-changed new - [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ] - 3bi ; ! FIXME - -! ====================================== -! IRC client messages -! ====================================== - -: /NICK ( nick -- ) - "NICK " irc-write irc-print ; - -: /LOGIN ( nick -- ) - dup /NICK - "USER " irc-write irc-write - " hostname servername :irc.factor" irc-print ; - -: /CONNECT ( server port -- stream ) - irc> connect>> call( host port -- stream local ) drop ; - -: /JOIN ( channel password -- ) - "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; - -: /PONG ( text -- ) - "PONG " irc-write irc-print ; - -! ====================================== -! Server message handling -! ====================================== - -GENERIC: initialize-chat ( chat -- ) -M: irc-chat initialize-chat drop ; -M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; - -GENERIC: forward-name ( irc-message -- name ) -M: join forward-name trailing>> ; -M: part forward-name channel>> ; -M: kick forward-name channel>> ; -M: mode forward-name name>> ; -M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; - -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 -- ) - -M: irc-message forward-message - +server-chat+ chat> [ to-chat ] [ drop ] if* ; - -M: single-forward forward-message dup forward-name to-chat ; - -M: multiple-forward forward-message - dup sender>> chats-with-participant to-chat ; - -M: broadcast-forward forward-message - irc> chats>> values [ to-chat ] with each ; - -GENERIC: process-message ( irc-message -- ) -M: object process-message drop ; -M: rpl-welcome process-message - nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri - values [ initialize-chat ] each ; -M: ping process-message trailing>> /PONG ; -M: rpl-nickname-in-use process-message name>> "_" append /NICK ; - -M: join process-message - [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri - dup chat> [ add-participant ] [ 3drop ] if ; - -M: part process-message - [ sender>> ] [ channel>> ] bi remove-participant ; - -M: kick process-message - [ [ user>> ] [ channel>> ] bi remove-participant ] - [ dup user>> me? [ unregister-chat ] [ drop ] if ] - bi ; - -M: quit process-message - sender>> remove-participant-from-all ; - -M: nick process-message - [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; - -M: mode process-message ( mode -- ) - dup channel-mode? [ - [ name>> ] [ mode>> ] [ parameter>> ] tri - [ change-participant-mode ] [ 2drop ] if* - ] [ drop ] if ; - -: >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; - -: names-reply>participants ( names-reply -- participants ) - nicks>> [ blank? ] trim " " split - [ >nick/mode 2array ] map >hashtable ; - -: maybe-clean-participants ( channel-chat -- ) - dup clean-participants>> [ - H{ } clone >>participants f >>clean-participants - ] when drop ; - -M: rpl-names process-message - [ names-reply>participants ] [ channel>> chat> ] bi [ - [ maybe-clean-participants ] - [ participants>> 2array assoc-combine ] - [ (>>participants) ] tri - ] [ drop ] if* ; - -M: rpl-names-end process-message - channel>> chat> [ - t >>clean-participants - [ f f f ] dip name>> to-chat - ] when* ; - -! ====================================== -! Client message handling -! ====================================== - -GENERIC: handle-outgoing-irc ( irc-message -- ? ) -M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>string irc-print t ; - -! ====================================== -! Reader/Writer -! ====================================== - -: handle-reader-message ( irc-message -- ) - irc> in-messages>> mailbox-put ; - -DEFER: (connect-irc) - -: (handle-disconnect) ( -- ) - irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] - [ dup reconnect-time>> sleep (connect-irc) ] - [ nick>> /LOGIN ] - tri ; - -! FIXME: do something with the exception, store somewhere to help debugging -: handle-disconnect ( error -- ? ) - drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; - -: (reader-loop) ( -- ? ) - irc> stream>> [ - |dispose stream-readln [ - string>irc-message handle-reader-message t - ] [ - f handle-disconnect - ] if* - ] with-destructors ; - -: reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover ; - -: writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; - -! ====================================== -! Processing loops -! ====================================== - -: in-multiplexer-loop ( -- ? ) - irc> in-messages>> mailbox-get - [ forward-message ] [ process-message ] [ irc-end? not ] tri ; - -: strings>privmsg ( name string -- privmsg ) - " :" prepend append "PRIVMSG " prepend string>irc-message ; - -: maybe-annotate-with-name ( name obj -- obj ) - { { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] - } cond ; - -GENERIC: annotate-message ( chat object -- object ) -M: object annotate-message nip ; -M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>target ; -M: string annotate-message [ name>> ] dip strings>privmsg ; - -: spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-server - [ writer-loop ] "irc-writer-loop" spawn-server - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server - 3drop ; - -GENERIC: (attach-chat) ( irc-chat -- ) - -M: irc-chat (attach-chat) - [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] - [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] - bi ; - -M: irc-server-chat (attach-chat) - irc> >>client +server-chat+ irc> chats>> set-at ; - -GENERIC: (remove-chat) ( irc-chat -- ) - -M: irc-nick-chat (remove-chat) - name>> unregister-chat ; - -M: irc-channel-chat (remove-chat) - [ part new annotate-message irc> out-messages>> mailbox-put ] keep - name>> unregister-chat ; - -M: irc-server-chat (remove-chat) - drop +server-chat+ unregister-chat ; - -: (connect-irc) ( irc-client -- ) - { - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] - [ (>>stream) ] - [ t swap (>>is-running) ] - [ in-messages>> [ irc-connected ] dip mailbox-put ] - } cleave ; - -: with-irc-client ( irc-client quot: ( -- ) -- ) - [ \ current-irc-client ] dip with-variable ; inline - -PRIVATE> - : connect-irc ( irc-client -- ) - dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; - -: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; - -: detach-chat ( irc-chat -- ) - [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; - -: speak ( message irc-chat -- ) - [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ; + [ (connect-irc) (do-login) spawn-irc ] with-irc ; +: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ; +: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ; +: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ; +: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/internals/internals-tests.factor similarity index 57% rename from extra/irc/client/client-tests.factor rename to extra/irc/client/internals/internals-tests.factor index 9e96cc249b..e358e59058 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -1,10 +1,13 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test accessors arrays sequences - io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages - concurrency.mailboxes classes assocs combinators irc.messages.parser ; +io io.streams.duplex namespaces threads destructors +calendar concurrency.mailboxes classes assocs combinators +irc.messages.parser irc.client.base irc.client.chats +irc.client.participants irc.client.internals ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ -IN: irc.client.tests +IN: irc.client.internals.tests ! Streams for testing TUPLE: mb-writer lines last-line disposed ; @@ -28,19 +31,20 @@ M: mb-writer dispose drop ; t >>is-ready t >>is-running >>stream - dup [ spawn-irc yield ] with-irc-client ; + dup [ spawn-irc yield ] with-irc ; -! to be used inside with-irc-client quotations -: %add-named-chat ( chat -- ) irc> attach-chat ; +! to be used inside with-irc quotations +: %add-named-chat ( chat -- ) (attach-chat) ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; -: %join ( channel -- ) irc> attach-chat ; +: %push-lines ( lines -- ) [ %push-line ] each ; +: %join ( channel -- ) (attach-chat) ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; : with-irc ( quot: ( -- ) -- ) - [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline + [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! TESTS @@ -50,13 +54,11 @@ M: mb-writer dispose drop ; { "factorbot" } [ irc> nick>> ] unit-test -! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message forward-name ] unit-test + string>irc-message chat-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - string>irc-message forward-name ] unit-test + string>irc-message chat-name ] unit-test ] with-irc { privmsg "#channel" "hello" } [ @@ -75,7 +77,12 @@ M: mb-writer dispose drop ; { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ "someserver" irc-port "factorbot" f [ 2drop t ] >>connect - [ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri + [ + (connect-irc) + (do-login) + irc> stream>> out>> lines>> + (terminate-irc) + ] with-irc ] unit-test ! Test join @@ -84,22 +91,15 @@ M: mb-writer dispose drop ; ] unit-test ] with-irc -[ { join_ "#factortest" } [ +[ { join_ "#factortest"} [ "#factortest" [ %add-named-chat ] keep { ":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 - in-messages>> 0.1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi - ] unit-test -] with-irc - -[ { T{ participant-changed f "somebody" +join+ } } [ - "#factortest" [ %add-named-chat ] keep - ":somebody!n=somebody@some.where JOIN :#factortest" %push-line - [ participant-changed? ] read-matching-message + } %push-lines + [ join? ] read-matching-message + [ class ] [ channel>> ] bi ] unit-test ] with-irc @@ -119,112 +119,95 @@ M: mb-writer dispose drop ; ] unit-test ] with-irc -[ { mode } [ +[ { mode "#factortest" "+ns" } [ "#factortest" [ %add-named-chat ] keep ":ircserver.net MODE #factortest +ns" %push-line - [ mode? ] read-matching-message class + [ mode? ] read-matching-message + [ class ] [ name>> ] [ mode>> ] tri ] unit-test ] with-irc ! Participant lists tests -[ { H{ { "ircuser" +normal+ } } } [ +[ { { "ircuser" } } [ "#factortest" [ %add-named-chat ] keep ":ircuser!n=user@isp.net JOIN :#factortest" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser!n=user@isp.net PART #factortest" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser!n=user@isp.net QUIT" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [ "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants + "ircuser" over join-participant [ %add-named-chat ] keep ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line participants>> ] unit-test ] with-irc -[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [ +[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } } + { "ircuser" T{ participant { nick "ircuser" } } } + { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [ "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants + "ircuser" over join-participant [ %add-named-chat ] keep - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 353 factorbot @ #factortest :ircuser2 " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced " + ":ircserver.net 353 factorbot @ #factortest :ircuser " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + } %push-lines participants>> ] unit-test ] with-irc -! Namelist change notification -[ { T{ participant-changed f f f f } } [ - "#factortest" [ %add-named-chat ] 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 "ircuser" +part+ f } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user@isp.net QUIT" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -! Mode change -[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [ +[ { mode "#factortest" "+o" "ircuser" } [ "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant ":ircserver.net MODE #factortest +o ircuser" %push-line - [ participant-changed? ] read-matching-message + [ mode? ] read-matching-message + { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave + ] unit-test +] with-irc + +[ { T{ participant { nick "ircuser" } { operator t } } } [ + "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant + ":ircserver.net MODE #factortest +o ircuser" %push-line + participants>> "ircuser" swap at ] unit-test ] with-irc ! Send privmsg [ { "PRIVMSG #factortest :hello" } [ "#factortest" [ %add-named-chat ] keep - "hello" swap speak %pop-output-line + "hello" swap (speak) %pop-output-line ] unit-test ] with-irc diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor new file mode 100644 index 0000000000..2081ae4510 --- /dev/null +++ b/extra/irc/client/internals/internals.factor @@ -0,0 +1,162 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs arrays concurrency.mailboxes continuations destructors +hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces +strings words.symbol irc.messages.base irc.client.participants fry threads +combinators irc.messages.parser ; +EXCLUDE: sequences => join ; +IN: irc.client.internals + +: /NICK ( nick -- ) "NICK " prepend irc-print ; +: /PONG ( text -- ) "PONG " prepend irc-print ; + +: /LOGIN ( nick -- ) + dup /NICK + "USER " prepend " hostname servername :irc.factor" append irc-print ; + +: /CONNECT ( server port -- stream ) + irc> connect>> call( host port -- stream local ) drop ; + +: /JOIN ( channel password -- ) + [ " :" swap 3append ] when* "JOIN " prepend irc-print ; + +: (connect-irc) ( -- ) + irc> { + [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] + [ (>>stream) ] + [ t swap (>>is-running) ] + [ in-messages>> [ irc-connected ] dip mailbox-put ] + } cleave ; + +: (do-login) ( -- ) irc> nick>> /LOGIN ; + +GENERIC: initialize-chat ( chat -- ) +M: irc-chat initialize-chat drop ; +M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; + +GENERIC: chat-put ( message obj -- ) +M: irc-chat chat-put in-messages>> mailbox-put ; +M: symbol chat-put chat> [ chat-put ] [ drop ] if* ; +M: string chat-put chat> +server-chat+ or chat-put ; +M: sequence chat-put [ chat-put ] with each ; + +: delete-chat ( name -- ) irc> chats>> delete-at ; +: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ; + +! Server message handling + +GENERIC: forward-message ( irc-message -- ) +M: irc-message forward-message +server-chat+ chat-put ; +M: to-one-chat forward-message dup chat> chat-put ; +M: to-all-chats forward-message chats> chat-put ; +M: to-many-chats forward-message dup sender>> participant-chats chat-put ; + +GENERIC: process-message ( irc-message -- ) +M: object process-message drop ; +M: ping process-message trailing>> /PONG ; +M: join process-message [ sender>> ] [ chat> ] bi join-participant ; +M: part process-message [ sender>> ] [ chat> ] bi part-participant ; +M: quit process-message sender>> quit-participant ; +M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ; +M: rpl-nickname-in-use process-message name>> "_" append /NICK ; + +M: rpl-welcome process-message + irc> + swap nickname>> >>nick + t >>is-ready + chats>> values [ initialize-chat ] each ; + +M: kick process-message + [ [ user>> ] [ chat> ] bi part-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] + bi ; + +M: participant-mode process-message ( participant-mode -- ) + [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ; + +M: rpl-names process-message + [ nicks>> ] [ chat> ] bi dup ?clear-participants + '[ _ join-participant ] each ; + +M: rpl-names-end process-message chat> t >>clear-participants drop ; + +! Client message handling + +GENERIC: handle-outgoing-irc ( irc-message -- ? ) +M: irc-end handle-outgoing-irc drop f ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; + +! Reader/Writer + +: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; + +: (handle-disconnect) ( -- ) + irc> in-messages>> irc-disconnected swap mailbox-put + irc> reconnect-time>> sleep + (connect-irc) + (do-login) ; + +: handle-disconnect ( error -- ? ) + [ irc> exceptions>> push ] when* + irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; + +GENERIC: handle-input ( line/f -- ? ) +M: string handle-input string>irc-message handle-reader-message t ; +M: f handle-input handle-disconnect ; + +: (reader-loop) ( -- ? ) + stream> [ |dispose stream-readln handle-input ] with-destructors ; + +: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ; +: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ; + +! Processing loops + +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> mailbox-get + [ process-message ] [ forward-message ] [ irc-end? not ] tri ; + +: strings>privmsg ( name string -- privmsg ) + " :" prepend append "PRIVMSG " prepend string>irc-message ; + +GENERIC: annotate-message ( chat object -- object ) +M: object annotate-message nip ; +M: to-channel annotate-message swap name>> >>channel ; +M: to-target annotate-message swap name>> >>target ; +M: mode annotate-message swap name>> >>name ; +M: string annotate-message [ name>> ] dip strings>privmsg ; + +: spawn-irc ( -- ) + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; + +GENERIC: (attach-chat) ( irc-chat -- ) + +M: irc-chat (attach-chat) + irc> + [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ] + [ is-ready>> [ initialize-chat ] [ drop ] if ] + 2bi ; + +M: irc-server-chat (attach-chat) + irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ; + +GENERIC: remove-chat ( irc-chat -- ) +M: irc-nick-chat remove-chat name>> unregister-chat ; +M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ; + +M: irc-channel-chat remove-chat + [ part new annotate-message irc-send ] + [ name>> unregister-chat ] bi ; + +: (terminate-irc) ( -- ) + irc> dup is-running>> [ + f >>is-running + [ stream>> dispose ] keep + [ in-messages>> ] [ out-messages>> ] bi 2array + [ irc-end swap mailbox-put ] each + ] [ drop ] if ; + +: (speak) ( message irc-chat -- ) swap annotate-message irc-send ; \ No newline at end of file diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor new file mode 100644 index 0000000000..8d367dbb95 --- /dev/null +++ b/extra/irc/client/participants/participants.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators fry hashtables +irc.client.base irc.client.chats kernel sequences splitting ; +IN: irc.client.participants + +TUPLE: participant nick operator voice ; +: ( name -- participant ) + { + { [ "@" ?head ] [ t f ] } + { [ "+" ?head ] [ f t ] } + [ f f ] + } cond participant boa ; + +GENERIC: has-participant? ( name irc-chat -- ? ) +M: irc-chat has-participant? 2drop f ; +M: irc-channel-chat has-participant? participants>> key? ; + +: rename-X ( new old assoc quot: ( obj value -- obj ) -- ) + '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline + +: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ; +: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ; +: part-participant ( nick irc-chat -- ) participants>> delete-at ; +: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ; + +: quit-participant ( nick -- ) + dup participant-chats [ part-participant ] with each ; + +: rename-participant* ( new old -- ) + [ dup participant-chats [ rename-participant ] with with each ] + [ dup chat> [ rename-nick-chat ] [ 2drop ] if ] + 2bi ; + +: join-participant ( nick irc-channel-chat -- ) + participants>> [ dup nick>> ] dip set-at ; + +: apply-mode ( ? participant mode -- ) + { + { CHAR: o [ (>>operator) ] } + { CHAR: v [ (>>voice) ] } + [ 3drop ] + } case ; + +: apply-modes ( mode-line participant -- ) + [ unclip CHAR: + = ] dip + '[ [ _ _ ] dip apply-mode ] each ; + +: change-participant-mode ( mode channel nick -- ) + swap chat> participants>> at apply-modes ; + +: ?clear-participants ( channel-chat -- ) + dup clear-participants>> [ + f >>clear-participants participants>> clear-assoc + ] [ drop ] if ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index e0f9a15eff..32d19906f0 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order words assocs strings - irc.messages.base ; +arrays classes.tuple math.order words assocs strings irc.messages.base ; EXCLUDE: sequences => join ; IN: irc.messages @@ -16,7 +15,7 @@ IRC: service "SERVICE" nickname _ distribution type _ : info ; IRC: quit "QUIT" : comment ; IRC: squit "SQUIT" server : comment ; ! channel operations -IRC: join "JOIN" channel ; +IRC: join "JOIN" : channel ; IRC: part "PART" channel : comment ; IRC: topic "TOPIC" channel : topic ; IRC: names "NAMES" channel ; @@ -61,3 +60,9 @@ IRC: rpl-names-end "366" nickname channel : comment ; ! error replies IRC: rpl-nickname-in-use "433" _ name ; IRC: rpl-nick-collision "436" nickname : comment ; + +M: rpl-names post-process-irc-message ( rpl-names -- ) + [ [ blank? ] trim " " split ] change-nicks drop ; + +PREDICATE: channel-mode < mode name>> first "#&" member? ; +PREDICATE: participant-mode < channel-mode parameter>> ; From 837ab3d982ea5b39466eee611e9243889e45c011 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:35:29 -0300 Subject: [PATCH 39/56] irc.gitbot: Fix USEs line --- extra/irc/gitbot/gitbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 3b7694a347..d145b3bd2c 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry irc.client irc.client.private kernel namespaces +USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.encodings.8-bit io.launcher io splitting make mason.common mason.updates calendar math alarms ; IN: irc.gitbot From 8eedc105a980c0c03d1c949e545fc26258d3564f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:47:55 -0300 Subject: [PATCH 40/56] Add missing bsd copyright notices, authors.txt, summary.txt files --- extra/irc/client/base/authors.txt | 1 + extra/irc/client/chats/authors.txt | 1 + extra/irc/client/chats/chats-docs.factor | 2 ++ extra/irc/client/chats/summary.txt | 1 + extra/irc/client/client-docs.factor | 2 ++ extra/irc/client/internals/authors.txt | 1 + extra/irc/client/internals/summary.txt | 1 + extra/irc/client/participants/authors.txt | 1 + extra/irc/client/participants/summary.txt | 1 + extra/irc/messages/messages-tests.factor | 2 ++ extra/irc/messages/messages.factor | 2 +- 11 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 extra/irc/client/base/authors.txt create mode 100644 extra/irc/client/chats/authors.txt create mode 100644 extra/irc/client/chats/summary.txt create mode 100644 extra/irc/client/internals/authors.txt create mode 100644 extra/irc/client/internals/summary.txt create mode 100644 extra/irc/client/participants/authors.txt create mode 100644 extra/irc/client/participants/summary.txt diff --git a/extra/irc/client/base/authors.txt b/extra/irc/client/base/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/base/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/chats/authors.txt b/extra/irc/client/chats/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/chats/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor index 66fd1a207d..d84e38f499 100644 --- a/extra/irc/client/chats/chats-docs.factor +++ b/extra/irc/client/chats/chats-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax quotations kernel ; IN: irc.client.chats diff --git a/extra/irc/client/chats/summary.txt b/extra/irc/client/chats/summary.txt new file mode 100644 index 0000000000..6e9493bfa5 --- /dev/null +++ b/extra/irc/client/chats/summary.txt @@ -0,0 +1 @@ +IRC Client and Chat object definitions diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index ad674cb0c1..496c2caa32 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser irc.client.chats ; IN: irc.client diff --git a/extra/irc/client/internals/authors.txt b/extra/irc/client/internals/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/internals/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/internals/summary.txt b/extra/irc/client/internals/summary.txt new file mode 100644 index 0000000000..a831199ba0 --- /dev/null +++ b/extra/irc/client/internals/summary.txt @@ -0,0 +1 @@ +IRC Client internals diff --git a/extra/irc/client/participants/authors.txt b/extra/irc/client/participants/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/participants/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/participants/summary.txt b/extra/irc/client/participants/summary.txt new file mode 100644 index 0000000000..3e88e61f5d --- /dev/null +++ b/extra/irc/client/participants/summary.txt @@ -0,0 +1 @@ +IRC Client chat participants handling diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index d88eeabc73..74cd95c09a 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test accessors arrays irc.messages.parser irc.messages ; EXCLUDE: sequences => join ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 32d19906f0..2ea476e1b4 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Bruno Deferrari +! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators arrays classes.tuple math.order words assocs strings irc.messages.base ; From e8d37558cbbcebf6307e60f0137944fa09144da6 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:52:24 -0300 Subject: [PATCH 41/56] irc.client: Fix typos --- extra/irc/client/chats/chats-docs.factor | 2 +- extra/irc/client/client-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor index d84e38f499..8ab2968eb7 100644 --- a/extra/irc/client/chats/chats-docs.factor +++ b/extra/irc/client/chats/chats-docs.factor @@ -15,7 +15,7 @@ HELP: irc-profile "IRC Client profile object" ; HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ; -HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ; +HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ; HELP: irc-disconnected "Message sent to notify chats that connection was lost." ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 496c2caa32..aa0bcb3bf3 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -67,7 +67,7 @@ ARTICLE: "irc.client" "IRC Client" "Some special messages that are created by the library and not by the irc server." { $table { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " } - { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } + { { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." } { { $link irc-disconnected } " sent to notify chats that connection was lost." } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } From f26fccec9d6e07532b6be42c6df58eabab3e2e0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 12 Apr 2009 16:32:39 -0500 Subject: [PATCH 42/56] Too much inlining in id3 --- extra/id3/id3.factor | 66 ++++++++++++++++++++++---------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index a742a1f08d..a5671a5822 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -71,13 +71,13 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] { [ length id3v1-offset >= ] [ id3v1-length tail-slice* "TAG" head? ] - } 1&& ; inline + } 1&& ; : id3v1+? ( seq -- ? ) { [ length id3v1+-offset >= ] [ id3v1+-length tail-slice* "TAG+" head? ] - } 1&& ; inline + } 1&& ; : pair>frame ( string key -- frame/f ) over [ @@ -86,7 +86,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] swap >>data ] [ 2drop f - ] if ; inline + ] if ; : id3v1>frames ( id3v1 -- seq ) [ @@ -101,25 +101,25 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] ] output>array sift ; : seq>synchsafe ( seq -- n ) - 0 [ [ 7 shift ] dip bitor ] reduce ; inline + 0 [ [ 7 shift ] dip bitor ] reduce ; : synchsafe>seq ( n -- seq ) dup 1+ log2 1+ 7 / ceiling - [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline + [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; : filter-text-data ( data -- filtered ) - [ printable? ] filter ; inline + [ printable? ] filter ; : valid-tag? ( id -- ? ) - [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline + [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; : read-frame-data ( frame seq -- frame data ) - [ 10 over size>> 10 + ] dip filter-text-data ; inline + [ 10 over size>> 10 + ] dip filter-text-data ; : decode-text ( string -- string' ) dup 2 short head { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member? - utf16 ascii ? decode ; inline + utf16 ascii ? decode ; : (read-frame) ( seq -- frame ) [ ] dip @@ -128,20 +128,20 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ [ 4 8 ] dip subseq seq>synchsafe >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] - } cleave ; inline + } cleave ; : read-frame ( seq -- frame/f ) dup 4 head-slice valid-tag? - [ (read-frame) ] [ drop f ] if ; inline + [ (read-frame) ] [ drop f ] if ; : remove-frame ( seq frame -- seq ) - size>> 10 + tail-slice ; inline + size>> 10 + tail-slice ; : frames>assoc ( seq -- assoc ) - [ [ tag>> ] keep ] H{ } map>assoc ; inline + [ [ tag>> ] keep ] H{ } map>assoc ; : read-frames ( seq -- assoc ) - [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline + [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; : read-v2-header ( seq -- header ) [
] dip @@ -149,18 +149,18 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ [ 3 5 ] dip >array >>version ] [ [ 5 ] dip nth >>flags ] [ [ 6 10 ] dip seq>synchsafe >>size ] - } cleave ; inline + } cleave ; : merge-frames ( id3 assoc -- id3 ) - [ dup frames>> ] dip update ; inline + [ dup frames>> ] dip update ; : merge-id3v1 ( id3 -- id3 ) - dup id3v1>frames frames>assoc merge-frames ; inline + dup id3v1>frames frames>assoc merge-frames ; : read-v2-tags ( id3 seq -- id3 ) 10 cut-slice [ read-v2-header >>header ] - [ read-frames frames>assoc merge-frames ] bi* ; inline + [ read-frames frames>assoc merge-frames ] bi* ; : extract-v1-tags ( id3 seq -- id3 ) { @@ -170,11 +170,11 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ [ 90 94 ] dip subseq decode-text filter-text-data >>year ] [ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ] [ [ 124 ] dip nth number>string >>genre ] - } cleave ; inline + } cleave ; : read-v1-tags ( id3 seq -- id3 ) id3v1-offset tail-slice* 3 tail-slice - extract-v1-tags ; inline + extract-v1-tags ; : extract-v1+-tags ( id3 seq -- id3 ) { @@ -191,11 +191,11 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ [ 181 211 ] dip subseq decode-text >>genre-name ] [ [ 211 217 ] dip subseq decode-text >>start-time ] [ [ 217 223 ] dip subseq decode-text >>end-time ] - } cleave ; inline + } cleave ; : read-v1+-tags ( id3 seq -- id3 ) id3v1+-offset tail-slice* 4 tail-slice - extract-v1+-tags ; inline + extract-v1+-tags ; : parse-genre ( string -- n/f ) dup "(" ?head-slice drop ")" ?tail-slice drop @@ -203,7 +203,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] genres ?nth swap or ] [ drop - ] if ; inline + ] if ; : (mp3>id3) ( path -- id3v2/f ) [ @@ -218,29 +218,29 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] PRIVATE> : mp3>id3 ( path -- id3/f ) - dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline + dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; : find-id3-frame ( id3 name -- obj/f ) - swap frames>> at* [ data>> ] when ; inline + swap frames>> at* [ data>> ] when ; -: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline +: title ( id3 -- string/f ) "TIT2" find-id3-frame ; -: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline +: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; -: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline +: album ( id3 -- string/f ) "TALB" find-id3-frame ; -: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline +: year ( id3 -- string/f ) "TYER" find-id3-frame ; -: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline +: comment ( id3 -- string/f ) "COMM" find-id3-frame ; : genre ( id3 -- string/f ) - "TCON" find-id3-frame parse-genre ; inline + "TCON" find-id3-frame parse-genre ; : find-mp3s ( path -- seq ) - [ >lower ".mp3" tail? ] find-all-files ; inline + [ >lower ".mp3" tail? ] find-all-files ; : mp3-paths>id3s ( seq -- seq' ) - [ dup mp3>id3 ] { } map>assoc ; inline + [ dup mp3>id3 ] { } map>assoc ; : parse-mp3-directory ( path -- seq ) find-mp3s mp3-paths>id3s ; From d8f144a8e9bf578dfab69cc22bce6af4fa16cd5a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 19:44:46 -0300 Subject: [PATCH 43/56] irc: Fix problems in tests --- .../client/internals/internals-tests.factor | 34 +++++++++---------- extra/irc/messages/messages-tests.factor | 3 +- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index e358e59058..d20ae50bcc 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -43,7 +43,7 @@ M: mb-writer dispose drop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; -: with-irc ( quot: ( -- ) -- ) +: spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,7 +59,7 @@ M: mb-writer dispose drop ; { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" string>irc-message chat-name ] unit-test -] with-irc +] spawning-irc { privmsg "#channel" "hello" } [ "#channel" "hello" strings>privmsg @@ -71,7 +71,7 @@ M: mb-writer dispose drop ; ":some.where 001 factorbot2 :Welcome factorbot2" %push-line irc> nick>> ] unit-test -] with-irc +] spawning-irc ! Test connect { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ @@ -89,7 +89,7 @@ M: mb-writer dispose drop ; [ { "JOIN #factortest" } [ "#factortest" %join %pop-output-line ] unit-test -] with-irc +] spawning-irc [ { join_ "#factortest"} [ "#factortest" [ %add-named-chat ] keep @@ -101,7 +101,7 @@ M: mb-writer dispose drop ; [ join? ] read-matching-message [ class ] [ channel>> ] bi ] unit-test -] with-irc +] spawning-irc [ { privmsg "#factortest" "hello" } [ "#factortest" [ %add-named-chat ] keep @@ -109,7 +109,7 @@ M: mb-writer dispose drop ; [ privmsg? ] read-matching-message [ class ] [ target>> ] [ trailing>> ] tri ] unit-test -] with-irc +] spawning-irc [ { privmsg "factorbot" "hello" } [ "ircuser" [ %add-named-chat ] keep @@ -117,7 +117,7 @@ M: mb-writer dispose drop ; [ privmsg? ] read-matching-message [ class ] [ target>> ] [ trailing>> ] tri ] unit-test -] with-irc +] spawning-irc [ { mode "#factortest" "+ns" } [ "#factortest" [ %add-named-chat ] keep @@ -125,7 +125,7 @@ M: mb-writer dispose drop ; [ mode? ] read-matching-message [ class ] [ name>> ] [ mode>> ] tri ] unit-test -] with-irc +] spawning-irc ! Participant lists tests [ { { "ircuser" } } [ @@ -133,7 +133,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net JOIN :#factortest" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -142,7 +142,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net PART #factortest" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -151,7 +151,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net QUIT" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -160,7 +160,7 @@ M: mb-writer dispose drop ; ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [ "#factortest" @@ -169,7 +169,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line participants>> ] unit-test -] with-irc +] spawning-irc [ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } } { "ircuser" T{ participant { nick "ircuser" } } } @@ -186,7 +186,7 @@ M: mb-writer dispose drop ; } %push-lines participants>> ] unit-test -] with-irc +] spawning-irc [ { mode "#factortest" "+o" "ircuser" } [ "#factortest" [ %add-named-chat ] keep @@ -195,7 +195,7 @@ M: mb-writer dispose drop ; [ mode? ] read-matching-message { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave ] unit-test -] with-irc +] spawning-irc [ { T{ participant { nick "ircuser" } { operator t } } } [ "#factortest" [ %add-named-chat ] keep @@ -203,11 +203,11 @@ M: mb-writer dispose drop ; ":ircserver.net MODE #factortest +o ircuser" %push-line participants>> "ircuser" swap at ] unit-test -] with-irc +] spawning-irc ! Send privmsg [ { "PRIVMSG #factortest :hello" } [ "#factortest" [ %add-named-chat ] keep "hello" swap (speak) %pop-output-line ] unit-test -] with-irc +] spawning-irc diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 74cd95c09a..218ed92018 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -26,7 +26,8 @@ IN: irc.messages.tests { command "JOIN" } { parameters { } } { trailing "#factortest" } - { sender "someuser" } } } + { sender "someuser" } + { channel "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" string>irc-message f >>timestamp ] unit-test From b6a8e023a5a0fcb64564178bfa42e590c575fae8 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 13 Apr 2009 01:17:04 +0200 Subject: [PATCH 44/56] Fix: setting WM_CLASS in X11 backend using UTF8 string --- basis/ui/backend/x11/x11.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 5a2a8974e7..d4b2959297 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -225,7 +225,7 @@ M: x-clipboard paste-clipboard utf8 encode dup length XChangeProperty drop ; : set-class ( dpy window -- ) - XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor" + XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor" utf8 encode dup length XChangeProperty drop ; M: x11-ui-backend set-title ( string world -- ) From 3b1f3c08a4a60498c834e5476603170ebe25ddd9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 03:16:57 -0500 Subject: [PATCH 45/56] Fix window positioning on OS X --- basis/ui/backend/cocoa/cocoa.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 1bbf46c69e..362305c8f7 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -39,13 +39,16 @@ M: pasteboard set-clipboard-contents [ 0 0 ] dip dim>> first2 ; : auto-position ( window loc -- ) + #! Note: if this is the initial window, the length of the windows + #! vector should be 1, since (open-window) calls auto-position + #! after register-window. dup { 0 0 } = [ drop - windows get [ -> center ] [ - peek second window-loc>> + windows get length 1 <= [ -> center ] [ + windows get peek second window-loc>> dupd first2 -> cascadeTopLeftFromPoint: -> setFrameTopLeftPoint: - ] if-empty + ] if ] [ first2 -> setFrameTopLeftPoint: ] if ; M: cocoa-ui-backend set-title ( string world -- ) From cedbad07723b5bc2942c5bf50794438b54313188 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 15:21:16 -0500 Subject: [PATCH 46/56] Fix tests to not clutter Factor directory --- basis/http/http-tests.factor | 6 +++++- extra/webapps/site-watcher/site-watcher.factor | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 45ad132677..5c73377cbe 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -393,6 +393,10 @@ SYMBOL: a [ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test ! Check that download throws errors (reported by Chris Double) -[ "http://localhost/tweet_my_twat" add-port download ] must-fail +[ + "resource:temp" [ + "http://localhost/tweet_my_twat" add-port download + ] with-directory +] must-fail [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index 7651afa4e6..edd8104a7e 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -69,7 +69,7 @@ IN: webapps.site-watcher 8431 >>secure ; : site-watcher-db ( -- db ) - "resource:test.db" ; + "test.db" temp-file ; From 69017ce41f757892a2e9d3bbcefb5993a9c44c12 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 14 Apr 2009 01:56:06 +0200 Subject: [PATCH 47/56] FUEL: fix for call( indentation. --- misc/fuel/fuel-syntax.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 7aba6282d6..1c88989366 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -262,7 +262,8 @@ ("\\_\\)" (1 "\\)" (2 "\\)" + (2 "" (1 ">b")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) @@ -275,6 +276,7 @@ ("\\_<\\(}\\)\\_>" (1 "){")) ;; Parenthesis: ("\\_<\\((\\)\\_>" (1 "()")) + ("\\_" (1 "()")) ("\\_<\\()\\)\\_>" (1 ")(")) ("\\_<(\\((\\)\\_>" (1 "()")) ("\\_<\\()\\))\\_>" (1 ")(")) From 1596d9aeaeeb27628ab0dea6344073a4d4324197 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 13 Apr 2009 19:03:17 -0500 Subject: [PATCH 48/56] mason: add workaround for cygwin git issue --- extra/mason/cleanup/cleanup.factor | 2 +- extra/mason/common/common.factor | 15 +++++++++++++-- extra/mason/release/archive/archive.factor | 2 +- extra/mason/release/tidy/tidy.factor | 4 ++-- 4 files changed, 17 insertions(+), 6 deletions(-) mode change 100644 => 100755 extra/mason/cleanup/cleanup.factor mode change 100644 => 100755 extra/mason/common/common.factor mode change 100644 => 100755 extra/mason/release/archive/archive.factor mode change 100644 => 100755 extra/mason/release/tidy/tidy.factor diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor old mode 100644 new mode 100755 index a2c087392a..a273696f51 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -18,6 +18,6 @@ IN: mason.cleanup build-dir [ compress-image compress-test-log - "factor" delete-tree + "factor" really-delete-tree ] with-directory ] unless ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor old mode 100644 new mode 100755 index 3cd38e1ff4..047bdaa844 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -2,11 +2,22 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories -io.launcher io.encodings.utf8 prettyprint +io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals ; +calendar.format arrays mason.config locals system ; IN: mason.common +HOOK: really-delete-tree os ( path -- ) + +M: windows really-delete-tree + #! Workaround: Cygwin GIT creates read-only files for + #! some reason. + [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ] + [ delete-tree ] + bi ; + +M: unix really-delete-tree delete-tree ; + : short-running-process ( command -- ) #! Give network operations at most 15 minutes to complete. diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor old mode 100644 new mode 100755 index 5ef424ad4f..fff8b83c23 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -29,7 +29,7 @@ IN: mason.release.archive "-fs" "HFS+" "-volname" "factor" } archive-name suffix try-process - "dmg-root" delete-tree ; + "dmg-root" really-delete-tree ; : make-unix-archive ( -- ) [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor old mode 100644 new mode 100755 index 497be09044..054b15f0f5 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -12,11 +12,11 @@ IN: mason.release.tidy append ; : remove-common-files ( -- ) - common-files [ delete-tree ] each ; + common-files [ really-delete-tree ] each ; : remove-factor-app ( -- ) target-os get "macosx" = - [ "Factor.app" delete-tree ] unless ; + [ "Factor.app" really-delete-tree ] unless ; : tidy ( -- ) "factor" [ remove-factor-app remove-common-files ] with-directory ; From 0ffd43e2e3a6e81af4370fec2224e9be2c846d83 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 19:48:08 -0500 Subject: [PATCH 49/56] 1.0/0.0 => 1/0. --- basis/db/tuples/tuples-tests.factor | 6 +++--- basis/furnace/cache/cache.factor | 2 +- basis/math/functions/functions-tests.factor | 4 ++-- basis/math/libm/libm-docs.factor | 2 +- basis/wrap/wrap.factor | 2 +- core/math/floats/floats-tests.factor | 2 -- core/math/integers/integers.factor | 2 +- extra/benchmark/raytracer/raytracer.factor | 2 +- 8 files changed, 10 insertions(+), 12 deletions(-) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index d4a58fa4fc..375ee509bb 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -411,7 +411,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples + T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples ] unit-test [ @@ -419,7 +419,7 @@ TUPLE: exam id name score ; T{ exam f 1 "Kyle" 100 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples ] unit-test [ @@ -430,7 +430,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples ] unit-test [ diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor index a5308c171e..fe2840c9eb 100644 --- a/basis/furnace/cache/cache.factor +++ b/basis/furnace/cache/cache.factor @@ -22,7 +22,7 @@ server-state f : expire-state ( class -- ) new - -1.0/0.0 millis [a,b] >>expires + -1/0. millis [a,b] >>expires delete-tuples ; TUPLE: server-state-manager < filter-responder timeout ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 4c9d151fd8..397a7cc2f3 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -22,9 +22,9 @@ IN: math.functions.tests [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test +[ 1/0. ] [ 0 -2 ^ ] unit-test [ t ] [ 0 0.0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test +[ 1/0. ] [ 0 -2.0 ^ ] unit-test [ 0 ] [ 0 3.0 ^ ] unit-test [ 0 ] [ 0 3 ^ ] unit-test diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index bf4c608d77..a890a59c19 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" $nl "They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" { $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } -{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" } +{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 58957ba8e7..482d50ab5f 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -30,7 +30,7 @@ SYMBOL: line-ideal { [ lines>> car 1list? ] [ top-fits? ] } 1|| ; :: min-by ( seq quot -- elt ) - f 1.0/0.0 seq [| key value new | + f 1/0. seq [| key value new | new quot call :> newvalue newvalue value < [ new newvalue ] [ key value ] if ] each drop ; inline diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 27cc510ea2..9f8f7b06fc 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -56,8 +56,6 @@ unit-test [ t ] [ 0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test -! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test - [ 0 ] [ 1/0. >bignum ] unit-test [ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index e88caa7703..868d9fc02e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -122,7 +122,7 @@ M: bignum (log2) bignum-log2 ; 2drop 0.0 ] [ dup zero? [ - 2drop 1.0/0.0 + 2drop 1/0. ] [ pre-scale /f-loop over odd? diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index a4df1fe04d..642b3dbb93 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -53,7 +53,7 @@ C: sphere : sphere-t ( b d -- t ) -+ dup 0.0 < - [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline + [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline : sphere-b&v ( sphere ray -- b v ) [ sphere-v ] [ nip ] 2bi From cb6f59ff5b4ef9b87ce059bc12e12f6b24feeea1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 20:25:55 -0500 Subject: [PATCH 50/56] Fix unit test failure in math.parser --- core/math/parser/parser.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0a637c2eab..3fd62e69a0 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -50,7 +50,9 @@ SYMBOL: radix SYMBOL: negative? : string>natural ( seq radix -- n/f ) - [ [ digit> ] dip (digits>integer) ] each-digit ; inline + over empty? [ 2drop f ] [ + [ [ digit> ] dip (digits>integer) ] each-digit + ] if ; inline : sign ( -- str ) negative? get "-" "+" ? ; From a4e62dfdba8f84ddd543379345d6600d6bc2af31 Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 13 Apr 2009 14:47:39 -0500 Subject: [PATCH 51/56] Fix for math.parser syntax change --- .../compiler/tree/propagation/recursive/recursive.factor | 4 ++-- basis/math/functions/functions.factor | 2 +- basis/math/intervals/intervals.factor | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 1bcd36f6b0..b8d1760a0b 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive { { [ 2dup interval-subset? ] [ empty-interval ] } { [ over empty-interval eq? ] [ empty-interval ] } - { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] } - { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] } + { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] } + { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] } [ [-inf,inf] ] } cond interval-union nip ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 1eac321e3b..a6beb87345 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -81,7 +81,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline + dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline : (^mod) ( n x y -- z ) make-bits 1 [ diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4fbc880971..02ea181f4e 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ; : [a,a] ( a -- interval ) closed-point dup ; foldable -: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline +: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline -: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline +: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline -: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline +: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline -: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline +: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline : [-inf,inf] ( -- interval ) full-interval ; inline From b1c1b4aba73ffb6401db40ca0b204b917ef1a86b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 15:11:32 -0500 Subject: [PATCH 52/56] Fix pango.layouts issue on 64-bit systems --- basis/pango/layouts/layouts.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index defcdec6f8..25aee74ca4 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine* pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ; FUNCTION: void -pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ; +pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ; FUNCTION: gboolean pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ; @@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics ) : line-offset>x ( layout n -- x ) #! n is an index into the UTF8 encoding of the text [ drop first-line ] [ swap string>> >utf8-index ] 2bi - f 0 [ pango_layout_line_index_to_x ] keep + 0 0 [ pango_layout_line_index_to_x ] keep *int pango>float ; : x>line-offset ( layout x -- n ) @@ -205,4 +205,4 @@ SYMBOL: cached-layouts : cached-line ( font string -- line ) cached-layout layout>> first-line ; -[ cached-layouts set-global ] "pango.layouts" add-init-hook \ No newline at end of file +[ cached-layouts set-global ] "pango.layouts" add-init-hook From b6ee0dca3be2c6fda889232eefe766706e01ce35 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 15:17:04 -0500 Subject: [PATCH 53/56] Fix compile warning --- build-support/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index ad64c541fe..2fec39f14a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -199,7 +199,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } c_find_word_size() { From 30a44225cd0201d810b0bb5d497820345528ac89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 14 Apr 2009 15:04:58 -0500 Subject: [PATCH 54/56] Fix code for floats syntax change --- basis/lcs/lcs.factor | 2 +- core/sequences/sequences-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 8c67590697..d32b199873 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -8,7 +8,7 @@ IN: lcs 0 1 ? + [ [ 1+ ] bi@ ] dip min min ; : lcs-step ( insert delete change same? -- next ) - 1 -1./0. ? + max max ; ! -1./0. is -inf (float) + 1 -1/0. ? + max max ; ! -1/0. is -inf (float) :: loop-step ( i j matrix old new step -- ) i j 1+ matrix nth nth ! insertion diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index da495f410f..85f9d56596 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -227,7 +227,7 @@ unit-test [ -3 10 nth ] must-fail [ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] must-fail +[ -1/0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test From 1c68b389cc0a07164137b09fb6d72797b78d48e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 14 Apr 2009 15:05:10 -0500 Subject: [PATCH 55/56] Document special float values --- core/math/parser/parser-docs.factor | 2 +- core/syntax/syntax-docs.factor | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index bcc75a842a..ba0df3e357 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -25,7 +25,7 @@ $nl ABOUT: "number-strings" HELP: digits>integer -{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } } +{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } } { $description "Converts a sequence of digits (with most significant digit first) into an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bb8791df97..33a0096ff9 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax" "7.e13" "1.0e-5" } +"There are three special float values:" +{ $table +{ "Positive infinity" { $snippet "1/0." } } +{ "Negative infinity" { $snippet "-1/0." } } +{ "Not-a-number" { $snippet "0/0." } } +} "More information on floats can be found in " { $link "floats" } "." ; ARTICLE: "syntax-complex-numbers" "Complex number syntax" From da38a259630ec91599030754680b92393d7882b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 14 Apr 2009 17:09:16 -0500 Subject: [PATCH 56/56] More float syntax fixes --- extra/math/analysis/analysis.factor | 4 ++-- extra/webapps/site-watcher/site-watcher.factor | 9 +++++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index fa01b0376d..a1fc0bd07b 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -42,7 +42,7 @@ PRIVATE> #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt #! gamma(n+1) = n! for n > 0 dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [ - drop 1./0. + drop 1/0. ] [ [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if ] if ; @@ -51,7 +51,7 @@ PRIVATE> #! gammaln(x) is an alternative when gamma(x)'s range #! varies too widely dup 0 < [ - drop 1./0. + drop 1/0. ] [ [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if ] if ; diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index edd8104a7e..b60f1b1b6a 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy -furnace.auth furnace.auth.features.deactivate-user +USING: accessors assocs db.sqlite furnace furnace.actions +furnace.alloy furnace.auth furnace.auth.features.deactivate-user furnace.auth.features.edit-profile furnace.auth.features.recover-password furnace.auth.features.registration furnace.auth.login furnace.boilerplate furnace.redirection html.forms http.server http.server.dispatchers kernel namespaces site-watcher site-watcher.db site-watcher.private urls validators io.sockets.secure.unix.debug -io.servers.connection db db.tuples sequences webapps.site-watcher.common -webapps.site-watcher.watching webapps.site-watcher.spidering ; +io.servers.connection io.files.temp db db.tuples sequences +webapps.site-watcher.common webapps.site-watcher.watching +webapps.site-watcher.spidering ; QUALIFIED: assocs IN: webapps.site-watcher