From 77e6f10ac3c3079f16c24e5d8fec8ac03610149e Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 18 Jul 2008 13:09:04 -0300 Subject: [PATCH 01/46] irc.client: Improvments to thread management. --- extra/irc/client/client.factor | 39 ++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 405d8ed9ed..bda00fcb95 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -63,6 +63,7 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed +SINGLETON: irc-listener-end ! send to a listener to top 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 @@ -85,7 +86,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: unregister-listener ( name -- ) irc> listeners>> delete-at ; + +: maybe-mailbox-get ( mailbox quot -- ) + [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -93,6 +96,12 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +: unregister-listener ( name -- ) + irc> listeners>> + [ at [ irc-listener-end ] dip to-listener ] + [ delete-at ] + 2bi ; + M: irc-listener to-listener ( message irc-listener -- ) in-messages>> mailbox-put ; @@ -291,18 +300,18 @@ DEFER: (connect-irc) ] if* ] with-destructors ; -: reader-loop ( -- ) - [ (reader-loop) ] [ handle-disconnect ] recover ; +: reader-loop ( -- ? ) + [ (reader-loop) ] [ handle-disconnect ] recover t ; -: writer-loop ( -- ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; +: writer-loop ( -- ? ) + irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; ! ====================================== ! Processing loops ! ====================================== -: in-multiplexer-loop ( -- ) - irc> in-messages>> mailbox-get handle-incoming-irc ; +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -314,12 +323,15 @@ DEFER: (connect-irc) [ nip ] } cond ; -: listener-loop ( name listener -- ) - out-messages>> mailbox-get maybe-annotate-with-name - irc> out-messages>> mailbox-put ; +: listener-loop ( name -- ? ) + dup listener> [ + out-messages>> [ maybe-annotate-with-name + irc> out-messages>> mailbox-put ] with + maybe-mailbox-get t + ] [ drop f ] if* ; : spawn-irc-loop ( quot name -- ) - [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip + [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -332,9 +344,8 @@ DEFER: (connect-irc) ! ====================================== : set+run-listener ( name irc-listener -- ) - [ '[ , , listener-loop ] "listener" spawn-irc-loop ] - [ swap irc> listeners>> set-at ] - 2bi ; + over irc> listeners>> set-at + '[ , listener-loop ] "listener" spawn-irc-loop ; GENERIC: (add-listener) ( irc-listener -- ) From 55d7cb31689114c665bbdf8a79894004068717d2 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 18 Jul 2008 16:36:40 -0300 Subject: [PATCH 02/46] irc.client: Two more tests --- extra/irc/client/client-tests.factor | 24 ++++++++++++++++++++---- extra/irc/client/client.factor | 5 +++-- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 100724ea58..641cb57562 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -64,7 +64,23 @@ IN: irc.client.tests [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri [ action>> ] [ nick>> ] bi ] unit-test -! TODO: channel message -! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" -! TODO: direct private message -! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file + +{ privmsg "#factortest" "hello" } [ + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] tri + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +{ privmsg "factorbot" "hello" } [ + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" + } make-client dup "factorbot" set-nick + [ listeners>> [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] tri + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index bda00fcb95..f4ef2a6d57 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -51,7 +51,8 @@ SYMBOL: +mode+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone + irc-channel-listener boa ; : ( name -- irc-nick-listener ) [ ] dip irc-nick-listener boa ; @@ -63,7 +64,7 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed -SINGLETON: irc-listener-end ! send to a listener to top its execution +SINGLETON: irc-listener-end ! send to a listener to stop its execution SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established From b855b098a79fb62d6dbdc0f12a8b7c153baabb29 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 26 Jul 2008 15:32:16 -0300 Subject: [PATCH 03/46] irc.client: Fixes, tests, etc --- extra/irc/client/client-tests.factor | 115 +++++++++++++---------- extra/irc/client/client.factor | 46 ++++----- extra/irc/messages/messages-tests.factor | 10 ++ extra/irc/messages/messages.factor | 68 ++++++++++---- 4 files changed, 145 insertions(+), 94 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 641cb57562..e4b7cd20ed 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 qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes assocs ; + concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -11,16 +11,16 @@ IN: irc.client.tests "\n" join ; : make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; + swap profile>> (>>nickname) ; -: with-dummy-client ( quot -- ) - rot with-variable ; inline +: with-dummy-client ( irc-client quot -- ) + [ current-irc-client ] dip with-variable ; inline -{ "" } make-client dup "factorbot" set-nick current-irc-client [ +{ "" } make-client dup "factorbot" set-nick [ { t } [ irc> profile>> nickname>> me? ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test @@ -32,55 +32,72 @@ IN: irc.client.tests { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" parse-irc-line irc-message-origin ] unit-test -] with-variable +] with-dummy-client ! Test login and nickname set -{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." - "NOTICE AUTH :*** Checking ident" - "NOTICE AUTH :*** Found your hostname" - "NOTICE AUTH :*** No identd (auth) response" - ":some.where 001 factorbot :Welcome factorbot" - } make-client - [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test +{ "factorbot" } [ + { "NOTICE AUTH :*** Looking up your hostname..." + "NOTICE AUTH :*** Checking ident" + "NOTICE AUTH :*** Found your hostname" + "NOTICE AUTH :*** No identd (auth) response" + ":some.where 001 factorbot :Welcome factorbot" + } make-client + { [ connect-irc ] + [ drop 1 seconds sleep ] + [ profile>> nickname>> ] + [ terminate-irc ] + } cleave ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" - ":ircserver.net MODE #factortest +ns" - ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." - ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } make-client dup "factorbot" set-nick - [ connect-irc ] keep 1 seconds sleep - join-messages>> 1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi ] unit-test + { ":factorbot!n=factorbo@some.where JOIN :#factortest" + ":ircserver.net MODE #factortest +ns" + ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" + } make-client + { [ "factorbot" set-nick ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ join-messages>> 1 seconds mailbox-get-timeout ] + [ terminate-irc ] + } cleave + [ class ] [ trailing>> ] bi ] unit-test { +join+ "somebody" } [ - { ":somebody!n=somebody@some.where JOIN :#factortest" - } make-client dup "factorbot" set-nick - [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri - [ action>> ] [ nick>> ] bi - ] unit-test + { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave + [ action>> ] [ nick>> ] bi + ] unit-test { privmsg "#factortest" "hello" } [ - { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" - } make-client dup "factorbot" set-nick - [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message ] bi ] tri - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test { privmsg "factorbot" "hello" } [ - { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" - } make-client dup "factorbot" set-nick - [ listeners>> [ "somedude" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "somedude" ] dip at - [ read-message drop ] [ read-message ] bi ] tri - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test \ No newline at end of file + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index f4ef2a6d57..888332dc1f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,8 +12,6 @@ IN: irc.client ! Setup and running objects ! ====================================== -SYMBOL: current-irc-client - : irc-port 6667 ; ! Default irc port TUPLE: irc-profile server port nickname password ; @@ -71,13 +69,17 @@ SINGLETON: irc-connected ! sent when connection is established UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri ; + [ is-running>> ] keep and [ + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] + [ stream>> dispose ] + tri + ] when* ; [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: maybe-mailbox-get ( mailbox quot -- ) +: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -240,8 +242,8 @@ M: quit handle-incoming-irc ( quit -- ) [ to-listener ] with each ] [ handle-participant-change ] [ prefix>> parse-name remove-participant-from-all ] - [ ] - } cleave call-next-method ; + [ call-next-method ] + } cleave ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -266,12 +268,6 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: irc-message handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - -M: part handle-outgoing-irc ( part -- ) - [ channel>> ] [ trailing>> "" or ] bi /PART ; - ! ====================================== ! Reader/Writer ! ====================================== @@ -283,7 +279,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip to-listener ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -318,10 +314,9 @@ DEFER: (connect-irc) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) - { - { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] + { { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name -- ? ) @@ -331,7 +326,7 @@ DEFER: (connect-irc) maybe-mailbox-get t ] [ drop f ] if* ; -: spawn-irc-loop ( quot name -- ) +: spawn-irc-loop ( quot: ( -- ? ) name -- ) [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; @@ -383,16 +378,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) t >>is-running in-messages>> [ irc-connected ] dip mailbox-put ; -: with-irc-client ( irc-client quot -- ) +: with-irc-client ( irc-client quot: ( -- ) -- ) [ current-irc-client ] dip with-variable ; inline PRIVATE> : connect-irc ( irc-client -- ) - dup [ - [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi - spawn-irc - ] with-irc-client ; + [ irc> + [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi + spawn-irc ] with-irc-client ; : add-listener ( irc-listener irc-client -- ) swap '[ , (add-listener) ] with-irc-client ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 1bd6088f82..876841abb7 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -35,3 +35,13 @@ join new [ ":someuser!n=user@some.where JOIN :#factortest" parse-irc-line f >>timestamp ] unit-test +mode new + ":ircserver.net MODE #factortest +ns" >>line + "ircserver.net" >>prefix + "MODE" >>command + { "#factortest" "+ns" } >>parameters + "#factortest" >>channel + "+ns" >>mode +1array +[ ":ircserver.net MODE #factortest +ns" + parse-irc-line 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 5813c72723..a5f82a5ae1 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order ; + arrays classes.tuple math.order quotations ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -17,7 +17,7 @@ TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name channel mode ; +TUPLE: mode < irc-message channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; @@ -25,12 +25,42 @@ TUPLE: unhandled < irc-message ; irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; +> ; +M: ping irc-command-string ( ping -- string ) drop "PING" ; +M: join irc-command-string ( join -- string ) drop "JOIN" ; +M: part irc-command-string ( part -- string ) drop "PART" ; +M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; +M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; +M: mode irc-command-string ( mode -- string ) drop "MODE" ; +M: kick irc-command-string ( kick -- string ) drop "KICK" ; + +GENERIC: irc-command-parameters ( irc-message -- seq ) + +M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; +M: ping irc-command-parameters ( ping -- seq ) drop { } ; +M: join irc-command-parameters ( join -- seq ) drop { } ; +M: part irc-command-parameters ( part -- seq ) name>> 1array ; +M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; +M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; +M: kick irc-command-parameters ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode irc-command-parameters ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; + +PRIVATE> + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] + [ irc-command-string ] + [ irc-command-parameters " " sjoin ] + [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) @@ -73,19 +103,19 @@ PRIVATE> : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ \ ping ] } - { "NOTICE" [ \ notice ] } - { "001" [ \ logged-in ] } - { "433" [ \ nick-in-use ] } - { "353" [ \ names-reply ] } - { "JOIN" [ \ join ] } - { "PART" [ \ part ] } - { "PRIVMSG" [ \ privmsg ] } - { "QUIT" [ \ quit ] } - { "MODE" [ \ mode ] } - { "KICK" [ \ kick ] } - [ drop \ unhandled ] + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; - + [ all-slots over [ length ] bi@ min head >quotation ] keep + '[ @ , boa nip ] call ; From 09c1fc390ba64b9a097f4e7ae93c88d54e45d4a5 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sun, 27 Jul 2008 20:15:38 -0400 Subject: [PATCH 04/46] Added server listener --- extra/irc/ui/ui.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 9b8d1a4d11..1520970f46 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -187,8 +187,9 @@ M: irc-tab ungraft* : ui-connect ( profile -- ui-window ) ui-window new over >>client swap [ connect-irc ] + [ [ ] dip add-listener ] [ listeners>> +server-listener+ swap at over - "Server" associate >>tabs ] bi ; + "Server" associate >>tabs ] tri ; : server-open ( server port nick password channels -- ) [ ui-connect [ irc-window ] keep ] dip From b30f22f125c3e4c949ad8cb4fd98b4cf8e881229 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 27 Jul 2008 21:19:28 -0300 Subject: [PATCH 05/46] irc.client: Fix removing of participant on quit --- 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 888332dc1f..42682154cd 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -117,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- ) with filter ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ delete-at ] with each ; + dup listeners-with-participant [ participants>> delete-at ] with each ; : add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; From 9f60dd601bfe417b153fdb68076abf69396da5be Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Mon, 28 Jul 2008 21:02:05 -0400 Subject: [PATCH 06/46] irc.ui: Fixed a few bugs --- extra/irc/ui/ui.factor | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 1520970f46..c91d797f25 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -6,9 +6,11 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels - io io.styles namespaces calendar calendar.format models + io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load ; + irc.ui.commandparser irc.ui.load qualified ; + +RENAME: join sequences => sjoin IN: irc.ui @@ -71,14 +73,21 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +: full-mode ( message -- mode ) + parameters>> rest " " sjoin ; + M: mode write-irc "* " blue write-color - [ name>> write ] keep + [ prefix>> parse-name write ] keep " has applied mode " blue write-color - [ mode>> write ] keep + [ full-mode write ] keep " to " blue write-color channel>> write ; +M: unhandled write-irc + "UNHANDLED: " write + line>> blue write-color ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -88,11 +97,17 @@ M: irc-disconnected write-irc M: irc-connected write-irc drop "* Connected" green write-color ; +M: irc-listener-end write-irc + drop ; + M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE +: time-happened ( irc-message -- timestamp ) + [ timestamp>> ] [ 2drop now ] recover ; + : print-irc ( irc-message -- ) - [ timestamp>> timestamp>hms write " " write ] + [ time-happened timestamp>hms write " " write ] [ write-irc nl ] bi ; : send-message ( message -- ) From a0782fb5991b0348ee11b2b7c51782aa55c42013 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 29 Jul 2008 00:48:25 -0300 Subject: [PATCH 07/46] irc.client: Don't forward quit messages to the server listener, tests for participant lists --- extra/irc/client/client-tests.factor | 58 ++++++++++++++++++++++++++++ extra/irc/client/client.factor | 15 ++++--- 2 files changed, 65 insertions(+), 8 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index e4b7cd20ed..166619f6cb 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -101,3 +101,61 @@ IN: irc.client.tests } cleave [ class ] [ name>> ] [ trailing>> ] tri ] unit-test + +! Participants lists tests +{ H{ { "somedude" f } } } [ + { ":somedude!n=user@isp.net JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude!n=user@isp.net PART #factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 42682154cd..89286f6303 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -218,7 +218,7 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - { [ maybe-forward-join ] ! keep + { [ maybe-forward-join ] [ dup trailing>> to-listener ] [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] @@ -231,19 +231,18 @@ M: part handle-incoming-irc ( part -- ) tri ; M: kick handle-incoming-irc ( kick -- ) - { [ dup channel>> to-listener ] + { [ dup channel>> to-listener ] [ [ who>> ] [ channel>> ] bi remove-participant ] [ handle-participant-change ] [ dup who>> me? [ unregister-listener ] [ drop ] if ] } cleave ; M: quit handle-incoming-irc ( quit -- ) - { [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ handle-participant-change ] - [ prefix>> parse-name remove-participant-from-all ] - [ call-next-method ] - } cleave ; + [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ prefix>> parse-name remove-participant-from-all ] + [ handle-participant-change ] + tri ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; From 5fd42c4e543ea6ffa7a42ae2be35afef9fa73854 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 29 Jul 2008 00:52:42 -0300 Subject: [PATCH 08/46] irc.client: For tests that need to wait, wait 0.1 seconds instead of 1 second. --- extra/irc/client/client-tests.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 166619f6cb..08307a2d5c 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -43,7 +43,7 @@ IN: irc.client.tests ":some.where 001 factorbot :Welcome factorbot" } make-client { [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ profile>> nickname>> ] [ terminate-irc ] } cleave ] unit-test @@ -57,8 +57,8 @@ IN: irc.client.tests } make-client { [ "factorbot" set-nick ] [ connect-irc ] - [ drop 1 seconds sleep ] - [ join-messages>> 1 seconds mailbox-get-timeout ] + [ drop 0.1 seconds sleep ] + [ join-messages>> 0.1 seconds mailbox-get-timeout ] [ terminate-irc ] } cleave [ class ] [ trailing>> ] bi ] unit-test @@ -109,7 +109,7 @@ IN: irc.client.tests [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -124,7 +124,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -139,7 +139,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -154,7 +154,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave From 65df4739ceec6713dc26ea27f0bfbab28ba9420b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jul 2008 15:37:40 -0500 Subject: [PATCH 09/46] Working on propagation, move some tests that don't apply out of cleanup-tests --- .../tree/cleanup/cleanup-tests.factor | 145 ------------------ .../compiler/tree/cleanup/cleanup.factor | 29 +++- .../tree/propagation/branches/branches.factor | 2 +- .../tree/propagation/info/info-tests.factor | 3 +- .../tree/propagation/info/info.factor | 24 +-- .../known-words/known-words.factor | 33 ++-- .../tree/propagation/propagation-tests.factor | 47 +++++- .../propagation/recursive/recursive.factor | 8 +- .../tree/propagation/simple/simple.factor | 16 +- .../tree/propagation/slots/slots.factor | 22 +-- .../strength-reduction-tests.factor | 119 ++++++++++++++ .../partial-dispatch/partial-dispatch.factor | 42 ++--- 12 files changed, 269 insertions(+), 221 deletions(-) create mode 100644 unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor index 75477508c9..22f53e2488 100644 --- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor +++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor @@ -166,19 +166,6 @@ M: object xyz ; \ +-integer-fixnum inlined? ] unit-test - -[ t ] [ - [ { string sbuf } declare ] \ push-all def>> append \ + inlined? -] unit-test - -[ t ] [ - [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? -] unit-test - -[ t ] [ - [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? -] unit-test - [ t ] [ [ { array-capacity } declare 0 < ] \ < inlined? ] unit-test @@ -277,11 +264,6 @@ cell-bits 32 = [ ] unit-test ] when -[ f ] [ - [ { integer } declare -63 shift 4095 bitand ] - \ shift inlined? -] unit-test - [ t ] [ [ B{ 1 0 } *short 0 number= ] \ number= inlined? @@ -328,36 +310,6 @@ cell-bits 32 = [ ] \ + inlined? ] unit-test -[ f ] [ - [ - 256 mod - ] { mod fixnum-mod } inlined? -] unit-test - -[ f ] [ - [ - dup 0 >= [ 256 mod ] when - ] { mod fixnum-mod } inlined? -] unit-test - -[ t ] [ - [ - { integer } declare dup 0 >= [ 256 mod ] when - ] { mod fixnum-mod } inlined? -] unit-test - -[ t ] [ - [ - { integer } declare 256 rem - ] { mod fixnum-mod } inlined? -] unit-test - -[ t ] [ - [ - { integer } declare [ 256 rem ] map - ] { mod fixnum-mod rem } inlined? -] unit-test - [ t ] [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test @@ -393,21 +345,6 @@ cell-bits 32 = [ [ 27/2 fib ] { < - } inlined? ] unit-test -: hang-regression ( m n -- x ) - over 0 number= [ - nip - ] [ - dup [ - drop 1 hang-regression - ] [ - dupd hang-regression hang-regression - ] if - ] if ; inline recursive - -[ t ] [ - [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if -] { } inlined? ] unit-test - [ t ] [ [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? ] unit-test @@ -421,16 +358,6 @@ cell-bits 32 = [ \ fixnum-bitand inlined? ] unit-test -[ t ] [ - [ { integer } declare 127 bitand 3 + ] - { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? -] unit-test - -[ f ] [ - [ { integer } declare 127 bitand 3 + ] - { >fixnum } inlined? -] unit-test - [ t ] [ [ { fixnum } declare [ drop ] each-integer ] { < <-integer-fixnum +-integer-fixnum + } inlined? @@ -456,22 +383,6 @@ cell-bits 32 = [ \ +-integer-fixnum inlined? ] unit-test -[ t ] [ - [ - { integer } declare - dup 0 >= [ - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] [ dup ] if - ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test - -[ t ] [ - [ - { fixnum } declare - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] { >fixnum } inlined? -] unit-test - [ f ] [ [ { integer } declare [ ] map @@ -490,56 +401,6 @@ cell-bits 32 = [ ] \ >fixnum inlined? ] unit-test -[ t ] [ - [ - { integer } declare 0 swap - [ - drop 615949 * 797807 + 20 2^ rem dup 19 2^ - - ] map - ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test - -[ t ] [ - [ - { fixnum } declare 0 swap - [ - drop 615949 * 797807 + 20 2^ rem dup 19 2^ - - ] map - ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? -] unit-test - -[ t ] [ - [ hashtable new ] \ new inlined? -] unit-test - -[ t ] [ - [ dup hashtable eq? [ new ] when ] \ new inlined? -] unit-test - -[ t ] [ - [ { hashtable } declare hashtable instance? ] \ instance? inlined? -] unit-test - -[ t ] [ - [ { vector } declare hashtable instance? ] \ instance? inlined? -] unit-test - -[ f ] [ - [ { assoc } declare hashtable instance? ] \ instance? inlined? -] unit-test - -TUPLE: declared-fixnum { x fixnum } ; - -[ t ] [ - [ { declared-fixnum } declare [ 1 + ] change-x ] - { + fixnum+ >fixnum } inlined? -] unit-test - -[ t ] [ - [ { declared-fixnum } declare x>> drop ] - { slot } inlined? -] unit-test - [ t ] [ [ { array } declare length @@ -565,12 +426,6 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test -[ t ] [ - [ - { integer } declare [ 256 mod ] map - ] { mod fixnum-mod } inlined? -] unit-test - [ t ] [ [ { integer } declare [ 0 >= ] map diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor index 7b4727ffcf..40a8da1562 100644 --- a/unfinished/compiler/tree/cleanup/cleanup.factor +++ b/unfinished/compiler/tree/cleanup/cleanup.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sequences.deep combinators fry -namespaces +classes.algebra namespaces assocs math math.private +math.partial-dispatch compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -20,7 +21,12 @@ GENERIC: cleanup* ( node -- node/nodes ) #! do it since the logic is a bit more involved [ cleanup* ] map flatten ; -: cleanup-constant-folding ( #call -- nodes ) +: cleanup-folding? ( #call -- ? ) + node-output-infos [ literal?>> ] all? ; + +: cleanup-folding ( #call -- nodes ) + #! Replace a #call having a known result with a #drop of its + #! inputs followed by #push nodes for the outputs. [ [ node-output-infos ] [ out-d>> ] bi [ [ literal>> ] dip #push ] 2map @@ -30,10 +36,27 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup-inlining ( #call -- nodes ) body>> cleanup ; +! Removing overflow checks +: no-overflow-variant ( op -- fast-op ) + H{ + { fixnum+ fixnum+fast } + { fixnum- fixnum-fast } + { fixnum* fixnum*fast } + { fixnum-shift fixnum-shift-fast } + } at ; + +: remove-overflow-check? ( #call -- ? ) + dup word>> no-overflow-variant + [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ; + +: remove-overflow-check ( #call -- #call ) + [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ; + M: #call cleanup* { - { [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] } { [ dup body>> ] [ cleanup-inlining ] } + { [ dup cleanup-folding? ] [ cleanup-folding ] } + { [ dup remove-overflow-check? ] [ remove-overflow-check ] } [ ] } cond ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 2442a796f2..bba920949b 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -24,7 +24,7 @@ GENERIC: live-branches ( #branch -- indices ) M: #if live-branches in-d>> first value-info class>> { - { [ dup null class<= ] [ { f f } ] } + { [ dup null-class? ] [ { f f } ] } { [ dup true-class? ] [ { t f } ] } { [ dup false-class? ] [ { f t } ] } [ { t t } ] diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 5991af92ee..24f4ca59dc 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -68,6 +68,5 @@ TUPLE: test-tuple { x read-only } ; [ t ] [ f f 3 3array test-tuple dup - object - value-info-intersect = + object-info value-info-intersect = ] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 93057aebc1..3d79840f7e 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -5,6 +5,12 @@ accessors math math.intervals namespaces sequences words combinators arrays compiler.tree.copy-equiv ; IN: compiler.tree.propagation.info +: false-class? ( class -- ? ) \ f class<= ; + +: true-class? ( class -- ? ) \ f class-not class<= ; + +: null-class? ( class -- ? ) null class<= ; + SYMBOL: +interval+ GENERIC: eql? ( obj1 obj2 -- ? ) @@ -29,6 +35,8 @@ slots ; : null-info T{ value-info f null empty-interval } ; inline +: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline + : class-interval ( class -- interval ) dup real class<= [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; @@ -57,7 +65,7 @@ slots ; dup literal>> class >>class dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval ] [ - dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [ + dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ null >>class empty-interval >>interval ] [ @@ -154,8 +162,8 @@ DEFER: (value-info-intersect) : value-info-intersect ( info1 info2 -- info ) { - { [ dup class>> null class<= ] [ nip ] } - { [ over class>> null class<= ] [ drop ] } + { [ dup class>> null-class? ] [ nip ] } + { [ over class>> null-class? ] [ drop ] } [ (value-info-intersect) ] } cond ; @@ -200,8 +208,8 @@ DEFER: (value-info-union) : value-info-union ( info1 info2 -- info ) { - { [ dup class>> null class<= ] [ drop ] } - { [ over class>> null class<= ] [ nip ] } + { [ dup class>> null-class? ] [ drop ] } + { [ over class>> null-class? ] [ nip ] } [ (value-info-union) ] } cond ; @@ -225,16 +233,12 @@ SYMBOL: value-infos : value-literal ( value -- obj ? ) value-info >literal< ; -: false-class? ( class -- ? ) \ f class<= ; - -: true-class? ( class -- ? ) \ f class-not class<= ; - : possible-boolean-values ( info -- values ) dup literal?>> [ literal>> 1array ] [ class>> { - { [ dup null class<= ] [ { } ] } + { [ dup null-class? ] [ { } ] } { [ dup true-class? ] [ { t } ] } { [ dup false-class? ] [ { f } ] } [ { t f } ] diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index af9d9bab4a..08fdb36cae 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -5,10 +5,12 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -compiler.tree.propagation.info compiler.tree.propagation.nodes -compiler.tree.propagation.constraints +compiler.tree.comparisons +compiler.tree.propagation.info +compiler.tree.propagation.nodes compiler.tree.propagation.slots -compiler.tree.comparisons ; +compiler.tree.propagation.simple +compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.known-words \ fixnum @@ -76,7 +78,7 @@ most-negative-fixnum most-positive-fixnum [a,b] : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ - 2dup [ null class<= ] either? [ 2drop null ] [ + 2dup [ null-class? ] either? [ 2drop null ] [ [ math-closure ] bi@ math-class-max ] if ; @@ -87,13 +89,13 @@ most-negative-fixnum most-positive-fixnum [a,b] [ fixnum class<= ] [ fixnum fits? ] bi* and ; : may-overflow ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ 2dup won't-overflow? [ [ integer math-class-max ] dip ] unless ] unless ; : may-be-rational ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ [ rational math-class-max ] dip ] unless ; @@ -107,7 +109,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ real math-class-min ] dip ; : float-valued ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ [ drop float ] dip ] unless ; @@ -167,7 +169,7 @@ generic-comparison-ops [ ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { - { incomparable [ object ] } + { incomparable [ object-info ] } { t [ t ] } { f [ f ] } } case ; @@ -184,7 +186,7 @@ generic-comparison-ops [ ] each : maybe-or-never ( ? -- info ) - [ object ] [ \ f ] if ; + [ object-info ] [ f ] if ; : info-intervals-intersect? ( info1 info2 -- ? ) [ interval>> ] bi@ intervals-intersect? ; @@ -259,5 +261,16 @@ generic-comparison-ops [ \ slot [ dup literal?>> - [ literal>> swap value-info-slot ] [ 2drop object ] if + [ literal>> swap value-info-slot ] [ 2drop object-info ] if +] +outputs+ set-word-prop + +\ instance? [ + [ value-info ] dip over literal>> class? [ + [ literal>> ] dip predicate-constraints + ] [ 2drop f ] if +] +constraints+ set-word-prop + +\ instance? [ + dup literal>> class? + [ literal>> predicate-output-infos ] [ 2drop f ] if ] +outputs+ set-word-prop diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 3c85665ba7..de6d6c72cb 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -5,7 +5,8 @@ accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts -compiler.tree.propagation.info slots.private ; +compiler.tree.propagation.info slots.private words hashtables +classes assocs ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -475,3 +476,47 @@ M: array iterate first t ; iterate [ dead-loop ] when ; inline recursive [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test + +: hang-1 ( m -- x ) + dup 0 number= [ hang-1 ] unless ; inline recursive + +[ ] [ [ 3 hang-1 ] final-info drop ] unit-test + +: hang-2 ( m n -- x ) + over 0 number= [ + nip + ] [ + dup [ + drop 1 hang-2 + ] [ + dupd hang-2 hang-2 + ] if + ] if ; inline recursive + +[ ] [ [ 3 over hang-2 ] final-info drop ] unit-test + +[ ] [ + [ + dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if + ] final-info drop +] unit-test + +[ V{ word } ] [ + [ { hashtable } declare hashtable instance? ] final-classes +] unit-test + +[ V{ POSTPONE: f } ] [ + [ { vector } declare hashtable instance? ] final-classes +] unit-test + +[ V{ object } ] [ + [ { assoc } declare hashtable instance? ] final-classes +] unit-test + +[ V{ word } ] [ + [ { string } declare string? ] final-classes +] unit-test + +[ V{ POSTPONE: f } ] [ + [ 3 string? ] final-classes +] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 97801e289e..425d5fb26f 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -29,8 +29,10 @@ IN: compiler.tree.propagation.recursive } cond nip interval-union ; : generalize-counter ( info' initial -- info ) - [ drop clone ] [ [ interval>> ] bi@ ] 2bi - generalize-counter-interval >>interval ; + 2dup [ class>> null-class? ] either? [ drop ] [ + [ drop clone ] [ [ interval>> ] bi@ ] 2bi + generalize-counter-interval >>interval + ] if ; : unify-recursive-stacks ( stacks initial -- infos ) over empty? [ nip ] [ @@ -65,7 +67,7 @@ M: #recursive propagate-around ( #recursive -- ) ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; : generalize-return-interval ( info -- info' ) - dup literal?>> [ + dup [ literal?>> ] [ class>> null-class? ] bi or [ clone [-inf,inf] >>interval ] unless ; diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index d0e2426b0c..589ad6db4c 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -17,7 +17,7 @@ IN: compiler.tree.propagation.simple ! Propagation for straight-line code. M: #introduce propagate-before - value>> object swap set-value-info ; + value>> object-info swap set-value-info ; M: #push propagate-before [ literal>> ] [ out-d>> first ] bi @@ -67,15 +67,27 @@ M: #declare propagate-before bi* with-datastack [ ] map ; +: predicate-output-infos ( info class -- info ) + [ class>> ] dip { + { [ 2dup class<= ] [ t ] } + { [ 2dup classes-intersect? not ] [ f ] } + [ object-info ] + } cond 2nip ; + +: propagate-predicate ( #call word -- infos ) + [ in-d>> first value-info ] [ "predicating" word-prop ] bi* + predicate-output-infos 1array ; + : default-output-value-infos ( #call word -- infos ) "default-output-classes" word-prop - [ class-infos ] [ out-d>> length object ] ?if ; + [ class-infos ] [ out-d>> length object-info ] ?if ; : output-value-infos ( #call word -- infos ) { { [ 2dup foldable-call? ] [ fold-call ] } { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } + { [ dup predicate? ] [ propagate-predicate ] } { [ dup +outputs+ word-prop ] [ call-outputs-quot ] } [ default-output-value-infos ] } cond ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 8a23d360cc..713ac1703f 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -3,7 +3,7 @@ USING: fry assocs arrays byte-arrays strings accessors sequences kernel slots classes.algebra classes.tuple classes.tuple.private words math math.private combinators sequences.private namespaces -classes compiler.tree.propagation.info ; +slots.private classes compiler.tree.propagation.info ; IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths @@ -60,27 +60,13 @@ UNION: fixed-length-sequence array byte-array string ; { \ [ propagate- ] } } case 1array ; -: tuple>array* ( tuple -- array ) - prepare-tuple>array - >r copy-tuple-slots r> - prefix ; - : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip dup [ read-only>> ] when ; : literal-info-slot ( slot object -- info/f ) - 2dup class read-only-slot? [ - { - { [ dup tuple? ] [ - [ 1- ] [ tuple>array* ] bi* nth - ] } - { [ dup complex? ] [ - [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi* - 2array nth - ] } - } cond - ] [ 2drop f ] if ; + 2dup class read-only-slot? + [ swap slot ] [ 2drop f ] if ; : length-accessor? ( slot info -- ? ) [ 1 = ] [ length>> ] bi* and ; @@ -92,4 +78,4 @@ UNION: fixed-length-sequence array byte-array string ; { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } [ [ 1- ] [ slots>> ] bi* ?nth ] - } cond [ object ] unless* ; + } cond [ object-info ] unless* ; diff --git a/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor new file mode 100644 index 0000000000..a940a63421 --- /dev/null +++ b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor @@ -0,0 +1,119 @@ +TUPLE: declared-fixnum { x fixnum } ; + +[ t ] [ + [ { declared-fixnum } declare [ 1 + ] change-x ] + { + fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { declared-fixnum } declare x>> drop ] + { slot } inlined? +] unit-test + +[ t ] [ + [ hashtable new ] \ new inlined? +] unit-test + +[ t ] [ + [ dup hashtable eq? [ new ] when ] \ new inlined? +] unit-test + +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] { >fixnum } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? +] unit-test + + + +[ t ] [ + [ + { integer } declare [ 256 mod ] map + ] { mod fixnum-mod } inlined? +] unit-test + + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test diff --git a/unfinished/math/partial-dispatch/partial-dispatch.factor b/unfinished/math/partial-dispatch/partial-dispatch.factor index 625770e09f..9211a41aa7 100644 --- a/unfinished/math/partial-dispatch/partial-dispatch.factor +++ b/unfinished/math/partial-dispatch/partial-dispatch.factor @@ -44,28 +44,23 @@ PREDICATE: math-partial < word bi ] "" make "math.partial-dispatch" lookup ; -: integer-op-word ( triple fix-word big-word -- word ) - [ - drop - name>> "fast" tail? >r - [ "-" % ] [ name>> % ] interleave - r> [ "-fast" % ] when - ] "" make "math.partial-dispatch" create ; +: integer-op-word ( triple -- word ) + [ name>> ] map "-" join "math.partial-dispatch" create ; -: integer-op-quot ( word fix-word big-word -- quot ) +: integer-op-quot ( triple fix-word big-word -- quot ) rot integer-op-combinator 1quotation 2curry ; -: define-integer-op-word ( word fix-word big-word -- ) +: define-integer-op-word ( triple fix-word big-word -- ) [ - [ integer-op-word ] [ integer-op-quot ] 3bi + [ 2drop integer-op-word ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared - ] - [ - [ integer-op-word ] [ 2drop ] 3bi + ] [ + 2drop + [ integer-op-word ] keep "derived-from" set-word-prop ] 3bi ; -: define-integer-op-words ( words fix-word big-word -- ) +: define-integer-op-words ( triples fix-word big-word -- ) [ define-integer-op-word ] 2curry each ; : integer-op-triples ( word -- triples ) @@ -78,7 +73,7 @@ PREDICATE: math-partial < word : define-integer-ops ( word fix-word big-word -- ) >r >r integer-op-triples r> r> [ define-integer-op-words ] - [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] + [ 2drop [ dup integer-op-word ] { } map>assoc % ] 3bi ; : define-math-ops ( op -- ) @@ -160,15 +155,10 @@ SYMBOL: fast-math-ops \ number= \ eq? \ bignum= define-integer-ops ] { } make >hashtable math-ops set-global - [ - { { + fixnum fixnum } fixnum+fast } , - { { - fixnum fixnum } fixnum-fast } , - { { * fixnum fixnum } fixnum*fast } , - { { shift fixnum fixnum } fixnum-shift-fast } , - - \ + \ fixnum+fast \ bignum+ define-integer-ops - \ - \ fixnum-fast \ bignum- define-integer-ops - \ * \ fixnum*fast \ bignum* define-integer-ops - \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops - ] { } make >hashtable fast-math-ops set-global + H{ + { { + fixnum fixnum } fixnum+fast } + { { - fixnum fixnum } fixnum-fast } + { { * fixnum fixnum } fixnum*fast } + { { shift fixnum fixnum } fixnum-shift-fast } + } fast-math-ops set-global ] with-compilation-unit From e61f2321d0c39b66acf8df37a2e0456d47d6758f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jul 2008 17:36:24 -0500 Subject: [PATCH 10/46] More debugging --- .../tree/cleanup/cleanup-tests.factor | 12 +++++------ .../compiler/tree/cleanup/cleanup.factor | 3 ++- .../tree/propagation/propagation-tests.factor | 8 +++++++ .../recursive/recursive-tests.factor | 19 +++++++++++++++++ .../propagation/recursive/recursive.factor | 4 ++-- .../tree/propagation/slots/slots.factor | 21 ++++++++++++++----- .../stack-checker/stack-checker-tests.factor | 2 +- 7 files changed, 54 insertions(+), 15 deletions(-) create mode 100644 unfinished/compiler/tree/propagation/recursive/recursive-tests.factor diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor index 22f53e2488..c483b8bdc6 100644 --- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor +++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor @@ -195,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- ) M: fixnum annotate-entry-test-1 drop ; -: (annotate-entry-test-2) ( from to quot: ( -- ) -- ) - 2over >= [ - 3drop +: (annotate-entry-test-2) ( from to -- ) + 2dup >= [ + 2drop ] [ - [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2) + >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2) ] if ; inline recursive : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline [ f ] [ - [ { bignum } declare [ ] annotate-entry-test-2 ] + [ { bignum } declare annotate-entry-test-2 ] \ annotate-entry-test-1 inlined? ] unit-test @@ -375,7 +375,7 @@ cell-bits 32 = [ [ t ] [ [ { fixnum } declare 0 [ + ] reduce ] - { < <-integer-fixnum } inlined? + { < <-integer-fixnum nth-unsafe } inlined? ] unit-test [ f ] [ diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor index 40a8da1562..08fd12f177 100644 --- a/unfinished/compiler/tree/cleanup/cleanup.factor +++ b/unfinished/compiler/tree/cleanup/cleanup.factor @@ -22,7 +22,8 @@ GENERIC: cleanup* ( node -- node/nodes ) [ cleanup* ] map flatten ; : cleanup-folding? ( #call -- ? ) - node-output-infos [ literal?>> ] all? ; + node-output-infos dup empty? + [ drop f ] [ [ literal?>> ] all? ] if ; : cleanup-folding ( #call -- nodes ) #! Replace a #call having a known result with a #drop of its diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index de6d6c72cb..c6e7865c48 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -520,3 +520,11 @@ M: array iterate first t ; [ V{ POSTPONE: f } ] [ [ 3 string? ] final-classes ] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare [ ] curry obj>> ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes +] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor new file mode 100644 index 0000000000..cf72a2a135 --- /dev/null +++ b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor @@ -0,0 +1,19 @@ +IN: compiler.tree.propagation.recursive.tests +USING: tools.test compiler.tree.propagation.recursive +math.intervals kernel ; + +[ T{ interval f { 0 t } { 1/0. t } } ] [ + T{ interval f { 1 t } { 1 t } } + T{ interval f { 0 t } { 0 t } } generalize-counter-interval +] unit-test + +[ T{ interval f { -1/0. t } { 10 t } } ] [ + T{ interval f { -1 t } { -1 t } } + T{ interval f { 10 t } { 10 t } } generalize-counter-interval +] unit-test + +[ t ] [ + T{ interval f { 1 t } { 268435455 t } } + T{ interval f { -268435456 t } { 268435455 t } } tuck + generalize-counter-interval = +] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 425d5fb26f..c5fb04e322 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -21,12 +21,12 @@ IN: compiler.tree.propagation.recursive : generalize-counter-interval ( interval initial-interval -- interval' ) { - { [ 2dup = ] [ empty-interval ] } + { [ 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] ] } [ [-inf,inf] ] - } cond nip interval-union ; + } cond interval-union nip ; : generalize-counter ( info' initial -- info ) 2dup [ class>> null-class? ] either? [ drop ] [ diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 713ac1703f..2924eb4369 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ; bi* value-info-intersect 1array ; : tuple-constructor? ( word -- ? ) - { } memq? ; + { curry compose } memq? ; : read-only-slots ( values class -- slots ) #! Delegation. @@ -41,22 +41,33 @@ UNION: fixed-length-sequence array byte-array string ; [ , f , [ literal>> ] map % ] { } make >tuple ; -: propagate- ( #call -- info ) - #! Delegation - in-d>> [ value-info ] map unclip-last - literal>> class>> [ read-only-slots ] keep +: (propagate-tuple-constructor) ( values class -- info ) + [ [ value-info ] map ] dip [ read-only-slots ] keep over 2 tail-slice [ dup [ literal?>> ] when ] all? [ [ 2 tail-slice ] dip fold- ] [ ] if ; +: propagate- ( #call -- info ) + #! Delegation + in-d>> unclip-last + value-info literal>> class>> (propagate-tuple-constructor) ; + +: propagate-curry ( #call -- info ) + in-d>> \ curry (propagate-tuple-constructor) ; + +: propagate-compose ( #call -- info ) + in-d>> \ compose (propagate-tuple-constructor) ; + : propagate- ( #call -- info ) in-d>> [ value-info ] map complex ; : propagate-tuple-constructor ( #call word -- infos ) { { \ [ propagate- ] } + { \ curry [ propagate-curry ] } + { \ compose [ propagate-compose ] } { \ [ propagate- ] } } case 1array ; diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor index 3fcbc2d023..3c7ae101e3 100755 --- a/unfinished/stack-checker/stack-checker-tests.factor +++ b/unfinished/stack-checker/stack-checker-tests.factor @@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector classes.tuple classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread -sequences.private destructors combinators ; +sequences.private destructors combinators eval ; IN: stack-checker.tests : short-effect ( effect -- pair ) From 9ded594f14344a5a64355522d22174cde3ce7b85 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jul 2008 16:11:03 -0500 Subject: [PATCH 11/46] springies.ui: Use color objects --- extra/springies/ui/ui.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index f2248ba6f2..75d3087fe5 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -23,7 +23,9 @@ IN: springies.ui GL_MODELVIEW glMatrixMode glLoadIdentity ; -: display ( -- ) set-projection black gl-color draw-nodes draw-springs ; +! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ; + +: display ( -- ) set-projection black set-color draw-nodes draw-springs ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 1906efc1bd9238061692ed341d85ac214b8d5b5d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jul 2008 16:11:21 -0500 Subject: [PATCH 12/46] ui.gadgets.slate: It slices! It dices! Order now and get a free apron! --- extra/ui/gadgets/slate/slate.factor | 87 ++++++++++++++++++++++++++++- 1 file changed, 86 insertions(+), 1 deletion(-) diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index 05b2de2e06..08e8b2765c 100644 --- a/extra/ui/gadgets/slate/slate.factor +++ b/extra/ui/gadgets/slate/slate.factor @@ -21,8 +21,93 @@ TUPLE: slate < gadget action pdim graft ungraft ; M: slate pref-dim* ( slate -- dim ) pdim>> ; -M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: combinators arrays sequences math math.geometry + opengl.gl ui.gadgets.worlds ; + +: screen-y* ( gadget -- loc ) + { + [ find-world height ] + [ screen-loc second ] + [ height ] + } + cleave + + - ; + +: screen-loc* ( gadget -- loc ) + { + [ screen-loc first ] + [ screen-y* ] + } + cleave + 2array ; + +: setup-viewport ( gadget -- gadget ) + dup + { + [ screen-loc* ] + [ dim>> ] + } + cleave + gl-viewport ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: default-coordinate-system ( gadget -- gadget ) + dup + { + [ drop 0 ] + [ width 1 - ] + [ height 1 - ] + [ drop 0 ] + } + cleave + -1 1 + glOrtho ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: slate graft* ( slate -- ) graft>> call ; M: slate ungraft* ( slate -- ) ungraft>> call ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: establish-coordinate-system ( gadget -- gadget ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate establish-coordinate-system ( slate -- slate ) + default-coordinate-system ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: draw-slate ( slate -- slate ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate draw-slate ( slate -- slate ) dup action>> call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate draw-gadget* ( slate -- ) + + GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity + + establish-coordinate-system + + GL_MODELVIEW glMatrixMode glLoadIdentity glPushMatrix + + setup-viewport + + draw-slate + + GL_PROJECTION glMatrixMode glPopMatrix + GL_MODELVIEW glMatrixMode glPopMatrix + + dup + find-world + default-coordinate-system + setup-viewport + drop + drop ; \ No newline at end of file From 22f2a0d856b5e680d74f20dad2d7646d4037bfad Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jul 2008 16:12:58 -0500 Subject: [PATCH 13/46] ui.gadgets.cartesian: Use the new slate --- extra/ui/gadgets/cartesian/cartesian.factor | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/extra/ui/gadgets/cartesian/cartesian.factor b/extra/ui/gadgets/cartesian/cartesian.factor index 027c1061a8..730b0f5b44 100644 --- a/extra/ui/gadgets/cartesian/cartesian.factor +++ b/extra/ui/gadgets/cartesian/cartesian.factor @@ -22,20 +22,15 @@ TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -M: cartesian draw-gadget* ( cartesian -- ) - GL_PROJECTION glMatrixMode - glLoadIdentity +M: cartesian establish-coordinate-system ( cartesian -- cartesian ) dup - { - [ x-min>> ] [ x-max>> ] - [ y-min>> ] [ y-max>> ] - [ z-min>> ] [ z-max>> ] - } - cleave - glOrtho - GL_MODELVIEW glMatrixMode - glLoadIdentity - call-next-method ; + { + [ x-min>> ] [ x-max>> ] + [ y-min>> ] [ y-max>> ] + [ z-min>> ] [ z-max>> ] + } + cleave + glOrtho ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 52085a4e49f983ec04e6efca4eea8c737c241d81 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jul 2008 16:13:27 -0500 Subject: [PATCH 14/46] ui.gadgets.plot: Use the new slate --- extra/ui/gadgets/plot/plot.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/plot/plot.factor b/extra/ui/gadgets/plot/plot.factor index 7eb79dd6fe..0a6f22f080 100644 --- a/extra/ui/gadgets/plot/plot.factor +++ b/extra/ui/gadgets/plot/plot.factor @@ -47,12 +47,14 @@ M: function plot-function ( plot function -- plot ) [ [ drop 0 ] [ y-min>> ] bi 2array ] [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ; -M: plot draw-gadget* ( plot -- ) - dup call-next-method +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: ui.gadgets.slate ; + +M: plot draw-slate ( plot -- plot ) 2 glLineWidth draw-axis plot-functions - drop fill-mode 1 glLineWidth ; From fcc1ee9cdd68cc37ac4df359fa4919422d0e8374 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 31 Jul 2008 21:35:09 -0300 Subject: [PATCH 15/46] irc.client: nick command parsing, namelist notification after join, tests. Make +normal+ the default state for participants, not 'f' --- extra/irc/client/client-tests.factor | 34 +++++++++++++++++------- extra/irc/client/client.factor | 8 +++--- extra/irc/messages/messages-tests.factor | 12 ++++++++- extra/irc/messages/messages.factor | 4 +++ 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 08307a2d5c..e021ff4ff4 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -103,7 +103,7 @@ IN: irc.client.tests ] unit-test ! Participants lists tests -{ H{ { "somedude" f } } } [ +{ H{ { "somedude" +normal+ } } } [ { ":somedude!n=user@isp.net JOIN :#factortest" } make-client { [ "factorbot" set-nick ] [ listeners>> @@ -115,13 +115,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude!n=user@isp.net PART #factortest" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -130,13 +130,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude!n=user@isp.net QUIT" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -145,13 +145,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -159,3 +159,17 @@ IN: irc.client.tests [ terminate-irc ] } cleave ] unit-test + +! Namelist notification +{ T{ participant-changed f f f } } [ + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 89286f6303..813de0f57c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -220,7 +220,7 @@ M: privmsg handle-incoming-irc ( privmsg -- ) M: join handle-incoming-irc ( join -- ) { [ maybe-forward-join ] [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] } cleave ; @@ -252,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- ) [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi - [ (>>participants) ] [ drop ] if* ; + [ names-reply>participants ] [ channel>> listener> ] bi [ + [ (>>participants) ] + [ [ f f ] dip name>> to-listener ] bi + ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 876841abb7..7ee0f41ab0 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -40,8 +40,18 @@ mode new "ircserver.net" >>prefix "MODE" >>command { "#factortest" "+ns" } >>parameters - "#factortest" >>channel + "#factortest" >>channel "+ns" >>mode 1array [ ":ircserver.net MODE #factortest +ns" + parse-irc-line f >>timestamp ] unit-test + +nick new + ":someuser!n=user@some.where NICK :someuser2" >>line + "someuser!n=user@some.where" >>prefix + "NICK" >>command + { } >>parameters + "someuser2" >>trailing +1array +[ ":someuser!n=user@some.where NICK :someuser2" parse-irc-line 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 a5f82a5ae1..3b9cf0af2c 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -12,6 +12,7 @@ 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 ; @@ -34,6 +35,7 @@ M: ping irc-command-string ( ping -- string ) drop "PING" ; M: join irc-command-string ( join -- string ) drop "JOIN" ; M: part irc-command-string ( part -- string ) drop "PART" ; M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: nick irc-command-string ( nick -- string ) drop "NICK" ; M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; M: mode irc-command-string ( mode -- string ) drop "MODE" ; @@ -46,6 +48,7 @@ M: ping irc-command-parameters ( ping -- seq ) drop { } ; M: join irc-command-parameters ( join -- seq ) drop { } ; M: part irc-command-parameters ( part -- seq ) name>> 1array ; M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: nick irc-command-parameters ( nick -- seq ) drop { } ; M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; M: kick irc-command-parameters ( kick -- seq ) @@ -110,6 +113,7 @@ PRIVATE> { "353" [ names-reply ] } { "JOIN" [ join ] } { "PART" [ part ] } + { "NICK" [ nick ] } { "PRIVMSG" [ privmsg ] } { "QUIT" [ quit ] } { "MODE" [ mode ] } From 804a76afc8be49b405402e78f90ecd5c698fdc50 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Thu, 31 Jul 2008 21:36:16 -0400 Subject: [PATCH 16/46] irc.ui: Userlists no longer use list gadgets --- extra/irc/ui/ui.factor | 36 +++++++++++++++--------------------- 1 file changed, 15 insertions(+), 21 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index c91d797f25..0ceeed1d35 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,7 +5,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private irc.ui.commandparser irc.ui.load qualified ; @@ -20,7 +20,7 @@ SYMBOL: client TUPLE: ui-window client tabs ; -TUPLE: irc-tab < frame listener client listmodel ; +TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; @@ -116,16 +116,15 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( assoc val -- alist ) - [ >alist ] dip - '[ second , = ] filter ; +: filter-participants ( pack alist val color -- ) + '[ , = [