From f936f5f54f90cfe042c5035fa71bfe8ef28428c7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 3 Sep 2008 23:56:58 -0300 Subject: [PATCH 01/38] irc.messages: use >tuple --- Makefile | 2 +- extra/irc/messages/messages.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 769aeacb8c..8831ed9c7e 100755 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 -fno-forward-propagate $(SITE_CFLAGS) endif ifdef CONFIG diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index d3eca92f15..e68cf12d2d 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -127,4 +127,4 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head >quotation ] keep - '[ @ , boa ] call ; + prefix >tuple ; From 7f588bbb8481a51eb6629032395798c4ace45702 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 4 Sep 2008 01:28:37 -0300 Subject: [PATCH 02/38] irc.messages: oops --- extra/irc/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index e68cf12d2d..3a9654dd6f 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -126,5 +126,5 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head >quotation ] keep + [ all-slots over [ length ] bi@ min head ] keep prefix >tuple ; From b610e0776992fe5c49193ec59ee2fdc1cacd6bf7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 5 Sep 2008 02:16:38 -0300 Subject: [PATCH 03/38] irc.messages: Change the way messages are built when parsed --- extra/irc/messages/messages.factor | 103 +++++++++++++++++------------ 1 file changed, 62 insertions(+), 41 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 3a9654dd6f..981844f187 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -19,7 +19,7 @@ TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message channel mode ; -TUPLE: names-reply < irc-message who = channel ; +TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; : ( command parameters trailing -- irc-message ) @@ -28,41 +28,55 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) -M: irc-message irc-command-string ( irc-message -- string ) command>> ; -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" ; -M: kick irc-command-string ( kick -- string ) drop "KICK" ; +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: irc-command-parameters ( irc-message -- seq ) +GENERIC: 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 ) channel>> 1array ; -M: quit irc-command-parameters ( quit -- seq ) drop { } ; -M: nick irc-command-parameters ( nick -- seq ) drop { } ; -M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; -M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; -M: kick irc-command-parameters ( kick -- 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 irc-command-parameters ( mode -- seq ) +M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +GENERIC: (>>command-parameters) ( params irc-message -- ) + +M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; +M: logged-in (>>command-parameters) ( params part -- ) >r first r> (>>name) ; +M: part (>>command-parameters) ( params part -- ) >r first r> (>>channel) ; +M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; +M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; +M: kick (>>command-parameters) ( params kick -- ) + >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; +M: mode (>>command-parameters) ( params mode -- ) + >r first2 r> [ (>>mode) ] [ (>>channel) ] bi ; ! FIXME +M: names-reply (>>command-parameters) ( params names-reply -- ) + [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; + PRIVATE> GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ irc-command-string ] - [ irc-command-parameters " " sjoin ] + [ command-string>> ] + [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; @@ -96,6 +110,15 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +: copy-contents ( origin dest -- ) + { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] + [ >r line>> r> (>>line) ] + [ >r prefix>> r> (>>prefix) ] + [ >r command>> r> (>>command) ] + [ >r trailing>> r> (>>trailing) ] + [ >r timestamp>> r> (>>timestamp) ] + } 2cleave ; + PRIVATE> UNION: sender-in-prefix privmsg join part quit kick mode nick ; @@ -111,20 +134,18 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) : 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 ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] + { "PING" [ ping new ] } + { "NOTICE" [ notice new ] } + { "001" [ logged-in new ] } + { "433" [ nick-in-use new ] } + { "353" [ names-reply new ] } + { "JOIN" [ join new ] } + { "PART" [ part new ] } + { "NICK" [ nick new ] } + { "PRIVMSG" [ privmsg new ] } + { "QUIT" [ quit new ] } + { "MODE" [ mode new ] } + { "KICK" [ kick new ] } + [ drop unhandled new ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep - prefix >tuple ; + [ copy-contents ] keep ; From db1d988988a96a08bc68daff3f5d8aaf34739811 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 5 Sep 2008 02:19:30 -0300 Subject: [PATCH 04/38] Makefile: oops, revert --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8831ed9c7e..769aeacb8c 100755 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 -fno-forward-propagate $(SITE_CFLAGS) + CFLAGS += -O3 $(SITE_CFLAGS) endif ifdef CONFIG From 50e5ffa594284d9eb4402627786bea26acc0a32b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Sep 2008 18:39:00 -0300 Subject: [PATCH 05/38] irc.messages: Handle mode messages better, tests --- extra/irc/messages/messages-tests.factor | 90 ++++++++++++++---------- extra/irc/messages/messages.factor | 48 ++++++++----- 2 files changed, 82 insertions(+), 56 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 20f4f1b277..ca8a4b1f50 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -6,54 +6,70 @@ IN: irc.messages.tests { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array +{ 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 -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array +{ T{ privmsg + { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } + { prefix "someuser!n=user@some.where" } + { command "PRIVMSG" } + { parameters { "#factortest" } } + { trailing "hi" } + { name "#factortest" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" parse-irc-line f >>timestamp ] unit-test -join new - ":someuser!n=user@some.where JOIN :#factortest" >>line - "someuser!n=user@some.where" >>prefix - "JOIN" >>command - { } >>parameters - "#factortest" >>trailing -1array +{ T{ join + { line ":someuser!n=user@some.where JOIN :#factortest" } + { prefix "someuser!n=user@some.where" } + { command "JOIN" } + { parameters { } } + { trailing "#factortest" } } } [ ":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 +{ T{ mode + { line ":ircserver.net MODE #factortest +ns" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+ns" } } + { channel "#factortest" } + { mode "+ns" } } } [ ":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 +{ T{ mode + { line ":ircserver.net MODE #factortest +o someuser" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+o" "someuser" } } + { channel "#factortest" } + { mode "+o" } + { parameter "someuser" } } } +[ ":ircserver.net MODE #factortest +o someuser" + parse-irc-line f >>timestamp ] unit-test + +{ T{ mode + { line ":ircserver.net MODE someuser +i" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "someuser" "+i" } } + { nickname "someuser" } + { mode "+i" } } } +[ ":ircserver.net MODE someuser +i" + parse-irc-line f >>timestamp ] unit-test + +{ T{ nick + { line ":someuser!n=user@some.where NICK :someuser2" } + { prefix "someuser!n=user@some.where" } + { command "NICK" } + { parameters { } } + { trailing "someuser2" } } } [ ":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 981844f187..6159c3d97d 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -18,7 +18,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 channel mode ; +TUPLE: mode < irc-message channel mode nickname parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; @@ -28,6 +28,9 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) M: irc-message command-string>> ( irc-message -- string ) command>> ; @@ -65,10 +68,18 @@ M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; M: kick (>>command-parameters) ( params kick -- ) >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; -M: mode (>>command-parameters) ( params mode -- ) - >r first2 r> [ (>>mode) ] [ (>>channel) ] bi ; ! FIXME M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; +M: mode (>>command-parameters) ( params mode -- ) + over first channel? [ + over length 3 = [ + >r first3 r> [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri + ] [ + >r first2 r> [ (>>mode) ] [ (>>channel) ] bi + ] if + ] [ + >r first2 r> [ (>>mode) ] [ (>>nickname) ] bi + ] if ; PRIVATE> @@ -110,7 +121,7 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; -: copy-contents ( origin dest -- ) +: copy-message-in ( origin dest -- ) { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] [ >r line>> r> (>>line) ] [ >r prefix>> r> (>>prefix) ] @@ -134,18 +145,17 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ ping new ] } - { "NOTICE" [ notice new ] } - { "001" [ logged-in new ] } - { "433" [ nick-in-use new ] } - { "353" [ names-reply new ] } - { "JOIN" [ join new ] } - { "PART" [ part new ] } - { "NICK" [ nick new ] } - { "PRIVMSG" [ privmsg new ] } - { "QUIT" [ quit new ] } - { "MODE" [ mode new ] } - { "KICK" [ kick new ] } - [ drop unhandled new ] - } case - [ copy-contents ] keep ; + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] + } case new [ copy-message-in ] keep ; From 007c68ab6baef0c92bd77f7c65f98715c79afca7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Sep 2008 19:29:18 -0300 Subject: [PATCH 06/38] irc.messages: handle mode parameters using inverse's switch --- extra/irc/messages/messages.factor | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 6159c3d97d..9cae8f6159 100755 --- 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 quotations ; + arrays classes.tuple math.order inverse ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -59,6 +59,9 @@ M: kick command-parameters>> ( kick -- seq ) M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +: (>>channel|nickname) ( string mode -- ) + over channel? [ (>>channel) ] [ (>>nickname) ] if ; + GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; @@ -71,15 +74,9 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - over first channel? [ - over length 3 = [ - >r first3 r> [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri - ] [ - >r first2 r> [ (>>mode) ] [ (>>channel) ] bi - ] if - ] [ - >r first2 r> [ (>>mode) ] [ (>>nickname) ] bi - ] if ; + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>channel|nickname) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri ] } + } switch ; PRIVATE> From 198e35fac2a7b4b9e9bb3a24cae1bdba7cb45283 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 7 Sep 2008 00:14:51 -0300 Subject: [PATCH 07/38] irc.messages: Remove nickname/channel distiction --- extra/irc/client/client.factor | 2 +- extra/irc/messages/messages-tests.factor | 14 ++------------ extra/irc/messages/messages.factor | 12 +++--------- 3 files changed, 6 insertions(+), 22 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 575c26972f..7d4c4977bb 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -183,7 +183,7 @@ GENERIC: forward-name ( irc-message -- name ) M: join forward-name ( join -- name ) trailing>> ; M: part forward-name ( part -- name ) channel>> ; M: kick forward-name ( kick -- name ) channel>> ; -M: mode forward-name ( mode -- name ) channel>> ; +M: mode forward-name ( mode -- name ) name>> ; M: privmsg forward-name ( privmsg -- name ) dup name>> me? [ irc-message-sender ] [ name>> ] if ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index ca8a4b1f50..b61dd16448 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -39,7 +39,7 @@ IN: irc.messages.tests { prefix "ircserver.net" } { command "MODE" } { parameters { "#factortest" "+ns" } } - { channel "#factortest" } + { name "#factortest" } { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" parse-irc-line f >>timestamp ] unit-test @@ -49,22 +49,12 @@ IN: irc.messages.tests { prefix "ircserver.net" } { command "MODE" } { parameters { "#factortest" "+o" "someuser" } } - { channel "#factortest" } + { name "#factortest" } { mode "+o" } { parameter "someuser" } } } [ ":ircserver.net MODE #factortest +o someuser" parse-irc-line f >>timestamp ] unit-test -{ T{ mode - { line ":ircserver.net MODE someuser +i" } - { prefix "ircserver.net" } - { command "MODE" } - { parameters { "someuser" "+i" } } - { nickname "someuser" } - { mode "+i" } } } -[ ":ircserver.net MODE someuser +i" - parse-irc-line f >>timestamp ] unit-test - { T{ nick { line ":someuser!n=user@some.where NICK :someuser2" } { prefix "someuser!n=user@some.where" } diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 9cae8f6159..bb78efd680 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -18,7 +18,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 channel mode nickname parameter ; +TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; @@ -28,9 +28,6 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) M: irc-message command-string>> ( irc-message -- string ) command>> ; @@ -59,9 +56,6 @@ M: kick command-parameters>> ( kick -- seq ) M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; -: (>>channel|nickname) ( string mode -- ) - over channel? [ (>>channel) ] [ (>>nickname) ] if ; - GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; @@ -74,8 +68,8 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>channel|nickname) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri ] } + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> From c3380865c107824ac6a7081b9de46f124ecdb71a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 11 Sep 2008 03:35:34 -0300 Subject: [PATCH 08/38] irc.messages: dip --- extra/irc/messages/messages.factor | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index bb78efd680..db25ba86d8 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -59,17 +59,18 @@ M: mode command-parameters>> ( mode -- seq ) GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; -M: logged-in (>>command-parameters) ( params part -- ) >r first r> (>>name) ; -M: part (>>command-parameters) ( params part -- ) >r first r> (>>channel) ; -M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; -M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; +M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ; +M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ; +M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ; +M: part (>>command-parameters) ( params part -- ) + [ first ] dip (>>channel) ; M: kick (>>command-parameters) ( params kick -- ) - >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; + [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; M: names-reply (>>command-parameters) ( params names-reply -- ) - [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; + [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } + { { [ [ 2array ] dip ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ [ 3array ] dip ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> @@ -113,12 +114,12 @@ M: irc-message irc-message>server-line ( irc-message -- string ) ":" split1 ; : copy-message-in ( origin dest -- ) - { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] - [ >r line>> r> (>>line) ] - [ >r prefix>> r> (>>prefix) ] - [ >r command>> r> (>>command) ] - [ >r trailing>> r> (>>trailing) ] - [ >r timestamp>> r> (>>timestamp) ] + { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] + [ [ line>> ] dip (>>line) ] + [ [ prefix>> ] dip (>>prefix) ] + [ [ command>> ] dip (>>command) ] + [ [ trailing>> ] dip (>>trailing) ] + [ [ timestamp>> ] dip (>>timestamp) ] } 2cleave ; PRIVATE> From 4f6ae2dee6bff6af2c3af5a8c1afbceb6108c1d2 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:15:48 -0700 Subject: [PATCH 09/38] Adding support for MacVim. --- basis/editors/macvim/authors.txt | 1 + basis/editors/macvim/macvim.factor | 13 +++++++++++++ basis/editors/macvim/summary.txt | 1 + basis/editors/macvim/tags.txt | 1 + 4 files changed, 16 insertions(+) create mode 100644 basis/editors/macvim/authors.txt create mode 100755 basis/editors/macvim/macvim.factor create mode 100644 basis/editors/macvim/summary.txt create mode 100644 basis/editors/macvim/tags.txt diff --git a/basis/editors/macvim/authors.txt b/basis/editors/macvim/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/macvim/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor new file mode 100755 index 0000000000..b5f864dcd0 --- /dev/null +++ b/basis/editors/macvim/macvim.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.macvim + +: macvim-location ( file line -- ) + drop + [ "open" , "-a" , "MacVim", , ] { } make + try-process ; + +[ macvim-location ] edit-hook set-global + + diff --git a/basis/editors/macvim/summary.txt b/basis/editors/macvim/summary.txt new file mode 100644 index 0000000000..894d635b47 --- /dev/null +++ b/basis/editors/macvim/summary.txt @@ -0,0 +1 @@ +MacVim editor integration diff --git a/basis/editors/macvim/tags.txt b/basis/editors/macvim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/macvim/tags.txt @@ -0,0 +1 @@ +unportable From b1231476c50f65af2936d1bd3e4d6bfefab1316d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:15:59 -0700 Subject: [PATCH 10/38] Adding support for TextEdit. --- basis/editors/textedit/authors.txt | 1 + basis/editors/textedit/summary.txt | 1 + basis/editors/textedit/tags.txt | 1 + basis/editors/textedit/textedit.factor | 13 +++++++++++++ 4 files changed, 16 insertions(+) create mode 100644 basis/editors/textedit/authors.txt create mode 100644 basis/editors/textedit/summary.txt create mode 100644 basis/editors/textedit/tags.txt create mode 100755 basis/editors/textedit/textedit.factor diff --git a/basis/editors/textedit/authors.txt b/basis/editors/textedit/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/textedit/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/textedit/summary.txt b/basis/editors/textedit/summary.txt new file mode 100644 index 0000000000..1d72d10db0 --- /dev/null +++ b/basis/editors/textedit/summary.txt @@ -0,0 +1 @@ +TextEdit editor integration diff --git a/basis/editors/textedit/tags.txt b/basis/editors/textedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor new file mode 100755 index 0000000000..6942e24534 --- /dev/null +++ b/basis/editors/textedit/textedit.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.textedit + +: textedit-location ( file line -- ) + drop + [ "open" , "-a" , "TextEdit", , ] { } make + try-process ; + +[ textedit-location ] edit-hook set-global + + From 571794ba057b403c1cdf23d99c033fbe9614a54e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:16:35 -0700 Subject: [PATCH 11/38] Initial version of printf. --- extra/printf/authors.txt | 1 + extra/printf/printf-tests.factor | 79 ++++++++++++++++++ extra/printf/printf.factor | 135 +++++++++++++++++++++++++++++++ 3 files changed, 215 insertions(+) create mode 100644 extra/printf/authors.txt create mode 100644 extra/printf/printf-tests.factor create mode 100644 extra/printf/printf.factor diff --git a/extra/printf/authors.txt b/extra/printf/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/printf/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor new file mode 100644 index 0000000000..b2a49573f7 --- /dev/null +++ b/extra/printf/printf-tests.factor @@ -0,0 +1,79 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel printf tools.test ; + +[ t ] [ "10" [ "%d" { 10 } sprintf ] call = ] unit-test + +[ t ] [ "123.456" [ "%f" { 123.456 } sprintf ] call = ] unit-test + +[ t ] [ "123.10" [ "%01.2f" { 123.1 } sprintf ] call = ] unit-test + +[ t ] [ "1.2345" [ "%.4f" { 1.23456789 } sprintf ] call = ] unit-test + +[ t ] [ " 1.23" [ "%6.2f" { 1.23456789 } sprintf ] call = ] unit-test + +[ t ] [ "3.625e+8" [ "%.3e" { 362525200 } sprintf ] call = ] unit-test + +[ t ] [ "2008-09-10" + [ "%04d-%02d-%02d" { 2008 9 10 } sprintf ] call = ] unit-test + +[ t ] [ "Hello, World!" + [ "%s" { "Hello, World!" } sprintf ] call = ] unit-test + +[ t ] [ "printf test" + [ "printf test" { } sprintf ] call = ] unit-test + +[ t ] [ "char a = 'a'" + [ "char %c = 'a'" { CHAR: a } sprintf ] call = ] unit-test + +[ t ] [ "00" [ "%02x" { HEX: 0 } sprintf ] call = ] unit-test + +[ t ] [ "ff" [ "%02x" { HEX: ff } sprintf ] call = ] unit-test + +[ t ] [ "signed -3 = unsigned 4294967293 = hex fffffffd" + [ "signed %d = unsigned %u = hex %x" { -3 -3 -3 } sprintf ] call = ] unit-test + +[ t ] [ "0 message(s)" + [ "%d %s(s)%" { 0 "message" } sprintf ] call = ] unit-test + +[ t ] [ "0 message(s) with %" + [ "%d %s(s) with %%" { 0 "message" } sprintf ] call = ] unit-test + +[ t ] [ "justif: \"left \"" + [ "justif: \"%-10s\"" { "left" } sprintf ] call = ] unit-test + +[ t ] [ "justif: \" right\"" + [ "justif: \"%10s\"" { "right" } sprintf ] call = ] unit-test + +[ t ] [ " 3: 0003 zero padded" + [ " 3: %04d zero padded" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " 3: 3 left justif" + [ " 3: %-4d left justif" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " 3: 3 right justif" + [ " 3: %4d right justif" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -003 zero padded" + [ " -3: %04d zero padded" { -3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -3 left justif" + [ " -3: %-4d left justif" { -3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -3 right justif" + [ " -3: %4d right justif" { -3 } sprintf ] call = ] unit-test + +[ t ] [ "There are 10 monkeys in the kitchen" + [ "There are %d monkeys in the %s" { 10 "kitchen" } sprintf ] call = ] unit-test + +[ f ] [ "%d" [ "%d" 10 sprintf ] call = ] unit-test + +[ t ] [ "[monkey]" [ "[%s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[ monkey]" [ "[%10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[monkey ]" [ "[%-10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[0000monkey]" [ "[%010s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[####monkey]" [ "[%'#10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[many monke]" [ "[%10.10s]" { "many monkeys" } sprintf ] call = ] unit-test + + diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor new file mode 100644 index 0000000000..8638afcca6 --- /dev/null +++ b/extra/printf/printf.factor @@ -0,0 +1,135 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: ascii io io.encodings.ascii io.files present kernel strings +math math.parser unicode.case sequences combinators +accessors namespaces prettyprint vectors ; + +IN: printf + +! FIXME: Handle invalid formats properly. +! FIXME: Handle incomplete formats properly. +! FIXME: Deal only with CHAR rather than converting to { CHAR } ? +! FIXME: Understand intermediate allocations that are happening... + +TUPLE: state type pad align width decimals neg loop ; + +SYMBOL: current + +SYMBOL: args + +>type + CHAR: \s >>pad + CHAR: r >>align + 0 >>width + -1 >>decimals + f >>neg + CHAR: % >>loop + current set ; + +: stop-% ( -- ) + current off ; + +: render ( s -- s ) + >vector + + current get decimals>> 0 >= current get type>> CHAR: f = and + [ CHAR: . swap dup rot swap index current get decimals>> + 1 + dup rot swap + CHAR: 0 pad-right swap 0 swap rot ] when + + current get align>> CHAR: l = + + [ current get neg>> [ { CHAR: - } prepend ] when + current get width>> CHAR: \s pad-right ] + + [ current get pad>> CHAR: \s = + [ current get neg>> [ { CHAR: - } prepend ] when + current get width>> current get pad>> pad-left ] + [ current get width>> current get neg>> [ 1 - ] when + current get pad>> pad-left + current get neg>> [ { CHAR: - } prepend ] when ] if + ] if + + current get decimals>> 0 >= current get type>> CHAR: f = not and + [ current get align>> CHAR: l = + [ current get decimals>> CHAR: \s pad-right ] + [ current get decimals>> current get pad>> pad-left ] if + current get decimals>> head-slice ] when + >string ; + +: loop-% ( c -- s ) + current get swap + { + { CHAR: % [ drop stop-% "%" ] } + { CHAR: ' [ CHAR: ' >>loop drop "" ] } + { CHAR: . [ CHAR: . >>loop 0 >>decimals drop "" ] } + { CHAR: - [ CHAR: l >>align drop "" ] } + { CHAR: 0 [ dup width>> 0 = [ CHAR: 0 >>pad ] when + [ 10 * 0 + ] change-width drop "" ] } + { CHAR: 1 [ [ 10 * 1 + ] change-width drop "" ] } + { CHAR: 2 [ [ 10 * 2 + ] change-width drop "" ] } + { CHAR: 3 [ [ 10 * 3 + ] change-width drop "" ] } + { CHAR: 4 [ [ 10 * 4 + ] change-width drop "" ] } + { CHAR: 5 [ [ 10 * 5 + ] change-width drop "" ] } + { CHAR: 6 [ [ 10 * 6 + ] change-width drop "" ] } + { CHAR: 7 [ [ 10 * 7 + ] change-width drop "" ] } + { CHAR: 8 [ [ 10 * 8 + ] change-width drop "" ] } + { CHAR: 9 [ [ 10 * 9 + ] change-width drop "" ] } + { CHAR: d [ CHAR: d >>type drop + args get pop >fixnum + dup 0 < [ current get t >>neg drop ] when + abs present render stop-% ] } + { CHAR: f [ CHAR: f >>type drop + args get pop >float + dup 0 < [ current get t >>neg drop ] when + abs present render stop-% ] } + { CHAR: s [ CHAR: s >>type drop + args get pop present render stop-% ] } + { CHAR: c [ CHAR: c >>type 1 >>width drop + 1 args get pop stop-% ] } + { CHAR: x [ CHAR: x >>type drop + args get pop >hex present render stop-% ] } + { CHAR: X [ CHAR: X >>type drop + args get pop >hex present >upper render stop-% ] } + [ drop drop stop-% "" ] + } case ; + +: loop-. ( c -- s ) + dup digit? current get swap + [ swap CHAR: 0 - swap [ 10 * + ] change-decimals drop "" ] + [ CHAR: % >>loop drop loop-% ] if ; + +: loop-' ( c -- s ) + current get swap >>pad CHAR: % >>loop drop "" ; + +: loop- ( c -- s ) + dup CHAR: % = [ drop start-% "" ] [ 1 swap ] if ; + +: loop ( c -- s ) + current get + [ current get loop>> + { + { CHAR: % [ loop-% ] } + { CHAR: ' [ loop-' ] } + { CHAR: . [ loop-. ] } + [ drop stop-% loop- ] ! FIXME: RAISE ERROR + } case ] + [ loop- ] if ; + +PRIVATE> + +: sprintf ( fmt args -- str ) + [ >vector reverse args set + V{ } swap [ loop append ] each >string ] with-scope ; + +: printf ( fmt args -- ) + sprintf print ; + +: fprintf ( path fmt args -- ) + rot ascii [ sprintf write flush ] with-file-appender ; + + From ccac749a70c336305fb98bf99967055986dcfe44 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 14 Sep 2008 10:04:04 -0700 Subject: [PATCH 12/38] Adding support for fry quotations. --- misc/factor.vim | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/misc/factor.vim b/misc/factor.vim index d1c46cee0b..90a3d46d50 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -131,18 +131,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim if exists("g:factor_norainbow") - syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL + syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL else - syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 - syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 - syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 - syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 - syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 - syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 - syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 - syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 - syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 - syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 + syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 + syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 + syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 + syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 + syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 + syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 + syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 + syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 + syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 + syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 endif if exists("g:factor_norainbow") From 55003480bc3b22645572d5006d6f5826f6c50e89 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 16 Sep 2008 17:26:28 -0700 Subject: [PATCH 13/38] Changing printf to use peg.ebnf. --- extra/printf/printf-tests.factor | 79 +++++++----- extra/printf/printf.factor | 209 ++++++++++++++----------------- 2 files changed, 141 insertions(+), 147 deletions(-) diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index b2a49573f7..05c33956d9 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -3,77 +3,90 @@ USING: kernel printf tools.test ; -[ t ] [ "10" [ "%d" { 10 } sprintf ] call = ] unit-test +[ t ] [ "10" [ { 10 } "%d" sprintf ] call = ] unit-test -[ t ] [ "123.456" [ "%f" { 123.456 } sprintf ] call = ] unit-test +[ t ] [ "123.456" [ { 123.456 } "%f" sprintf ] call = ] unit-test -[ t ] [ "123.10" [ "%01.2f" { 123.1 } sprintf ] call = ] unit-test +[ t ] [ "123.10" [ { 123.1 } "%01.2f" sprintf ] call = ] unit-test -[ t ] [ "1.2345" [ "%.4f" { 1.23456789 } sprintf ] call = ] unit-test +[ t ] [ "1.2345" [ { 1.23456789 } "%.4f" sprintf ] call = ] unit-test -[ t ] [ " 1.23" [ "%6.2f" { 1.23456789 } sprintf ] call = ] unit-test +[ t ] [ " 1.23" [ { 1.23456789 } "%6.2f" sprintf ] call = ] unit-test -[ t ] [ "3.625e+8" [ "%.3e" { 362525200 } sprintf ] call = ] unit-test +[ t ] [ "1.234e+08" [ { 123400000 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "1.234567e+08" [ { 123456700 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "3.625e+08" [ { 362525200 } "%.3e" sprintf ] call = ] unit-test + +[ t ] [ "2.5e-03" [ { 0.0025 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "2.5E-03" [ { 0.0025 } "%E" sprintf ] call = ] unit-test + +[ t ] [ "ff" [ { HEX: ff } "%x" sprintf ] call = ] unit-test + +[ t ] [ "FF" [ { HEX: ff } "%X" sprintf ] call = ] unit-test + +[ t ] [ "0f" [ { HEX: f } "%02x" sprintf ] call = ] unit-test + +[ t ] [ "0F" [ { HEX: f } "%02X" sprintf ] call = ] unit-test [ t ] [ "2008-09-10" - [ "%04d-%02d-%02d" { 2008 9 10 } sprintf ] call = ] unit-test + [ { 2008 9 10 } "%04d-%02d-%02d" sprintf ] call = ] unit-test [ t ] [ "Hello, World!" - [ "%s" { "Hello, World!" } sprintf ] call = ] unit-test + [ { "Hello, World!" } "%s" sprintf ] call = ] unit-test [ t ] [ "printf test" - [ "printf test" { } sprintf ] call = ] unit-test + [ { } "printf test" sprintf ] call = ] unit-test [ t ] [ "char a = 'a'" - [ "char %c = 'a'" { CHAR: a } sprintf ] call = ] unit-test + [ { CHAR: a } "char %c = 'a'" sprintf ] call = ] unit-test -[ t ] [ "00" [ "%02x" { HEX: 0 } sprintf ] call = ] unit-test +[ t ] [ "00" [ { HEX: 0 } "%02x" sprintf ] call = ] unit-test -[ t ] [ "ff" [ "%02x" { HEX: ff } sprintf ] call = ] unit-test - -[ t ] [ "signed -3 = unsigned 4294967293 = hex fffffffd" - [ "signed %d = unsigned %u = hex %x" { -3 -3 -3 } sprintf ] call = ] unit-test +[ t ] [ "ff" [ { HEX: ff } "%02x" sprintf ] call = ] unit-test [ t ] [ "0 message(s)" - [ "%d %s(s)%" { 0 "message" } sprintf ] call = ] unit-test + [ { 0 "message" } "%d %s(s)%" sprintf ] call = ] unit-test [ t ] [ "0 message(s) with %" - [ "%d %s(s) with %%" { 0 "message" } sprintf ] call = ] unit-test + [ { 0 "message" } "%d %s(s) with %%" sprintf ] call = ] unit-test [ t ] [ "justif: \"left \"" - [ "justif: \"%-10s\"" { "left" } sprintf ] call = ] unit-test + [ { "left" } "justif: \"%-10s\"" sprintf ] call = ] unit-test [ t ] [ "justif: \" right\"" - [ "justif: \"%10s\"" { "right" } sprintf ] call = ] unit-test + [ { "right" } "justif: \"%10s\"" sprintf ] call = ] unit-test [ t ] [ " 3: 0003 zero padded" - [ " 3: %04d zero padded" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %04d zero padded" sprintf ] call = ] unit-test [ t ] [ " 3: 3 left justif" - [ " 3: %-4d left justif" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %-4d left justif" sprintf ] call = ] unit-test [ t ] [ " 3: 3 right justif" - [ " 3: %4d right justif" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %4d right justif" sprintf ] call = ] unit-test [ t ] [ " -3: -003 zero padded" - [ " -3: %04d zero padded" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %04d zero padded" sprintf ] call = ] unit-test [ t ] [ " -3: -3 left justif" - [ " -3: %-4d left justif" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %-4d left justif" sprintf ] call = ] unit-test [ t ] [ " -3: -3 right justif" - [ " -3: %4d right justif" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %4d right justif" sprintf ] call = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - [ "There are %d monkeys in the %s" { 10 "kitchen" } sprintf ] call = ] unit-test + [ { 10 "kitchen" } "There are %d monkeys in the %s" sprintf ] call = ] unit-test -[ f ] [ "%d" [ "%d" 10 sprintf ] call = ] unit-test +[ f ] [ "%d" [ { 10 } "%d" sprintf ] call = ] unit-test -[ t ] [ "[monkey]" [ "[%s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[ monkey]" [ "[%10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[monkey ]" [ "[%-10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[0000monkey]" [ "[%010s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[####monkey]" [ "[%'#10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[many monke]" [ "[%10.10s]" { "many monkeys" } sprintf ] call = ] unit-test +[ t ] [ "[monkey]" [ { "monkey" } "[%s]" sprintf ] call = ] unit-test +[ t ] [ "[ monkey]" [ { "monkey" } "[%10s]" sprintf ] call = ] unit-test +[ t ] [ "[monkey ]" [ { "monkey" } "[%-10s]" sprintf ] call = ] unit-test +[ t ] [ "[0000monkey]" [ { "monkey" } "[%010s]" sprintf ] call = ] unit-test +[ t ] [ "[####monkey]" [ { "monkey" } "[%'#10s]" sprintf ] call = ] unit-test +[ t ] [ "[many monke]" [ { "many monkeys" } "[%10.10s]" sprintf ] call = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 8638afcca6..f46d08adfa 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,135 +1,116 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: ascii io io.encodings.ascii io.files present kernel strings -math math.parser unicode.case sequences combinators -accessors namespaces prettyprint vectors ; +USING: io io.encodings.ascii io.files +kernel sequences strings vectors math math.parser macros +fry peg.ebnf unicode.case arrays prettyprint quotations ; -IN: printf - -! FIXME: Handle invalid formats properly. -! FIXME: Handle incomplete formats properly. -! FIXME: Deal only with CHAR rather than converting to { CHAR } ? -! FIXME: Understand intermediate allocations that are happening... - -TUPLE: state type pad align width decimals neg loop ; - -SYMBOL: current - -SYMBOL: args +IN: printf >type - CHAR: \s >>pad - CHAR: r >>align - 0 >>width - -1 >>decimals - f >>neg - CHAR: % >>loop - current set ; +: compose-all ( seq -- quot ) + [ ] [ compose ] reduce ; -: stop-% ( -- ) - current off ; +: write-all ( seq -- quot ) + [ [ write ] append ] map ; -: render ( s -- s ) - >vector +: append-all ( seq -- string ) + SBUF" " [ dip swap append ] reduce ; - current get decimals>> 0 >= current get type>> CHAR: f = and - [ CHAR: . swap dup rot swap index current get decimals>> + 1 + dup rot swap - CHAR: 0 pad-right swap 0 swap rot ] when +: apply-format ( params quot -- params string ) + [ dup pop ] dip call ; - current get align>> CHAR: l = +: fix-neg ( string -- string ) + dup CHAR: 0 swap index 0 = + [ dup CHAR: - swap index dup + [ swap remove-nth "-" prepend ] + [ drop ] if ] when ; - [ current get neg>> [ { CHAR: - } prepend ] when - current get width>> CHAR: \s pad-right ] +: >digits ( string -- digits ) + dup length 0 > [ >string string>number ] [ drop 0 ] if ; - [ current get pad>> CHAR: \s = - [ current get neg>> [ { CHAR: - } prepend ] when - current get width>> current get pad>> pad-left ] - [ current get width>> current get neg>> [ 1 - ] when - current get pad>> pad-left - current get neg>> [ { CHAR: - } prepend ] when ] if - ] if +: zero-pad ( string digits -- string ) + swap dup + CHAR: . swap index rot + 1+ + dup rot swap + CHAR: 0 pad-right + swap head-slice ; - current get decimals>> 0 >= current get type>> CHAR: f = not and - [ current get align>> CHAR: l = - [ current get decimals>> CHAR: \s pad-right ] - [ current get decimals>> current get pad>> pad-left ] if - current get decimals>> head-slice ] when - >string ; - -: loop-% ( c -- s ) - current get swap - { - { CHAR: % [ drop stop-% "%" ] } - { CHAR: ' [ CHAR: ' >>loop drop "" ] } - { CHAR: . [ CHAR: . >>loop 0 >>decimals drop "" ] } - { CHAR: - [ CHAR: l >>align drop "" ] } - { CHAR: 0 [ dup width>> 0 = [ CHAR: 0 >>pad ] when - [ 10 * 0 + ] change-width drop "" ] } - { CHAR: 1 [ [ 10 * 1 + ] change-width drop "" ] } - { CHAR: 2 [ [ 10 * 2 + ] change-width drop "" ] } - { CHAR: 3 [ [ 10 * 3 + ] change-width drop "" ] } - { CHAR: 4 [ [ 10 * 4 + ] change-width drop "" ] } - { CHAR: 5 [ [ 10 * 5 + ] change-width drop "" ] } - { CHAR: 6 [ [ 10 * 6 + ] change-width drop "" ] } - { CHAR: 7 [ [ 10 * 7 + ] change-width drop "" ] } - { CHAR: 8 [ [ 10 * 8 + ] change-width drop "" ] } - { CHAR: 9 [ [ 10 * 9 + ] change-width drop "" ] } - { CHAR: d [ CHAR: d >>type drop - args get pop >fixnum - dup 0 < [ current get t >>neg drop ] when - abs present render stop-% ] } - { CHAR: f [ CHAR: f >>type drop - args get pop >float - dup 0 < [ current get t >>neg drop ] when - abs present render stop-% ] } - { CHAR: s [ CHAR: s >>type drop - args get pop present render stop-% ] } - { CHAR: c [ CHAR: c >>type 1 >>width drop - 1 args get pop stop-% ] } - { CHAR: x [ CHAR: x >>type drop - args get pop >hex present render stop-% ] } - { CHAR: X [ CHAR: X >>type drop - args get pop >hex present >upper render stop-% ] } - [ drop drop stop-% "" ] - } case ; - -: loop-. ( c -- s ) - dup digit? current get swap - [ swap CHAR: 0 - swap [ 10 * + ] change-decimals drop "" ] - [ CHAR: % >>loop drop loop-% ] if ; - -: loop-' ( c -- s ) - current get swap >>pad CHAR: % >>loop drop "" ; - -: loop- ( c -- s ) - dup CHAR: % = [ drop start-% "" ] [ 1 swap ] if ; - -: loop ( c -- s ) - current get - [ current get loop>> - { - { CHAR: % [ loop-% ] } - { CHAR: ' [ loop-' ] } - { CHAR: . [ loop-. ] } - [ drop stop-% loop- ] ! FIXME: RAISE ERROR - } case ] - [ loop- ] if ; +: >exponential ( n -- base exp ) + 0 + [ swap dup [ 10.0 > ] keep 1.0 < or ] + [ dup 10.0 > + [ 10.0 / [ 1+ ] dip swap ] + [ 10.0 * [ 1- ] dip swap ] if + ] [ swap ] while + [ number>string ] dip + dup abs number>string 2 CHAR: 0 pad-left + [ 0 < [ "-" ] [ "+" ] if ] dip append + "e" prepend ; PRIVATE> -: sprintf ( fmt args -- str ) - [ >vector reverse args set - V{ } swap [ loop append ] each >string ] with-scope ; +EBNF: parse-format-string -: printf ( fmt args -- ) - sprintf print ; +plain-text = (!("%").)+ => [[ >string 1quotation ]] + +percents = "%" => [[ '[ "%" ] ]] + +pad-zero = "0" => [[ CHAR: 0 ]] +pad-char = "'" (.) => [[ second ]] +pad-char_ = (pad-zero|pad-char)? => [[ CHAR: \s or 1quotation ]] +pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] +pad-width = ([0-9])* => [[ >digits 1quotation ]] +pad = (pad-align) (pad-char_) (pad-width) => [[ reverse compose-all ]] + +width = "." ([0-9])* => [[ second >digits '[ _ head-slice ] ]] +width_ = (width)? => [[ [ ] or ]] + +digits = "." ([0-9])* => [[ second >digits '[ _ zero-pad ] ]] +digits_ = (digits)? => [[ [ ] or ]] + +fmt-c = "c" => [[ [ 1string ] ]] +fmt-C = "C" => [[ [ 1string >upper ] ]] +chars = (fmt-c|fmt-C) => [[ '[ _ apply-format ] ]] + +fmt-s = "s" => [[ [ ] ]] +fmt-S = "S" => [[ [ >upper ] ]] +strings = (pad) (width_) (fmt-s|fmt-S) => [[ reverse compose-all '[ _ apply-format ] ]] + +fmt-d = "d" => [[ [ >fixnum number>string ] ]] +decimals = fmt-d + +fmt-e = "e" => [[ [ >exponential ] ]] +fmt-E = "E" => [[ [ >exponential >upper ] ]] +exps = (digits_) (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] + +fmt-f = "f" => [[ [ >float number>string ] ]] +floats = (digits_) (fmt-f) => [[ reverse compose-all ]] + +fmt-x = "x" => [[ [ >hex ] ]] +fmt-X = "X" => [[ [ >hex >upper ] ]] +hex = fmt-x | fmt-X + +numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append '[ _ apply-format ] ]] + +formats = "%" (chars|strings|numbers|percents) => [[ second ]] + +text = (formats|plain-text)* + +;EBNF + +MACRO: printf ( format-string -- ) + parse-format-string + '[ reverse >vector _ write-all compose-all call drop ] ; + +MACRO: sprintf ( format-string -- ) + parse-format-string + '[ reverse >vector _ append-all >string swap drop ] ; + +MACRO: fprintf ( format-string -- ) + parse-format-string + '[ reverse >vector _ write-all compose-all rot ascii [ call ] with-file-appender drop ] ; -: fprintf ( path fmt args -- ) - rot ascii [ sprintf write flush ] with-file-appender ; From 3e1303f784115b466e3b224290ab0b37a77e80b0 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 09:22:48 -0700 Subject: [PATCH 14/38] Adding documentation for printf, and improvements based on IRC feedback. --- extra/printf/printf-docs.factor | 47 ++++++++++++++++++ extra/printf/printf-tests.factor | 84 +++++++++++++++++--------------- extra/printf/printf.factor | 57 +++++++++------------- 3 files changed, 117 insertions(+), 71 deletions(-) create mode 100755 extra/printf/printf-docs.factor diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor new file mode 100755 index 0000000000..c1638f0d23 --- /dev/null +++ b/extra/printf/printf-docs.factor @@ -0,0 +1,47 @@ + +USING: help.syntax help.markup kernel prettyprint sequences strings ; + +IN: printf + +HELP: printf +{ $values { "format-string" string } } +{ $description + "Writes the arguments formatted according to the format string." + { $table + { "%%" "Single %" "" } + { "%Wd" "Integer W digits wide (e.g., \"1234\")" "fixnum" } + { "%W.De" "Scientific notation" "fixnum, float" } + { "%W.DE" "Scientific notation" "fixnum, float" } + { "%W.Df" "Fixed format" "fixnum, float" } + { "%Wx" "Hexadecimal" "hex" } + { "%WX" "Hexadecimal uppercase" "hex" } + { "%W.Ds" "String format" "string" } + { "%W.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + } +} +{ $examples + { $example + "USING: printf ;" + "{ 123 } \"%05d\" printf" + "00123" } + { $example + "USING: printf ;" + "{ HEX: ff } \"04X\" printf" + "00FF" } + { $example + "USING: printf ;" + "{ 1.23456789 } \"%.3f\" printf" + "1.234" } + { $example + "USING: printf ;" + "{ 1234567890 } \"%.5e\" printf" + "1.23456e+09" } +} ; + +HELP: sprintf +{ $values { "params" sequence } { "format-string" string } { "result" string } } +{ $description "Returns the arguments formatted according to the format string as a result string." } +{ $see-also printf } ; + diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 05c33956d9..7d89b35ae9 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -3,90 +3,98 @@ USING: kernel printf tools.test ; -[ t ] [ "10" [ { 10 } "%d" sprintf ] call = ] unit-test +[ "%s" printf ] must-infer -[ t ] [ "123.456" [ { 123.456 } "%f" sprintf ] call = ] unit-test +[ t ] [ "10" { 10 } "%d" sprintf = ] unit-test -[ t ] [ "123.10" [ { 123.1 } "%01.2f" sprintf ] call = ] unit-test +[ t ] [ "123.456" { 123.456 } "%f" sprintf = ] unit-test -[ t ] [ "1.2345" [ { 1.23456789 } "%.4f" sprintf ] call = ] unit-test +[ t ] [ "123.10" { 123.1 } "%01.2f" sprintf = ] unit-test -[ t ] [ " 1.23" [ { 1.23456789 } "%6.2f" sprintf ] call = ] unit-test +[ t ] [ "1.2345" { 1.23456789 } "%.4f" sprintf = ] unit-test -[ t ] [ "1.234e+08" [ { 123400000 } "%e" sprintf ] call = ] unit-test +[ t ] [ " 1.23" { 1.23456789 } "%6.2f" sprintf = ] unit-test -[ t ] [ "1.234567e+08" [ { 123456700 } "%e" sprintf ] call = ] unit-test +[ t ] [ "1.234e+08" { 123400000 } "%e" sprintf = ] unit-test -[ t ] [ "3.625e+08" [ { 362525200 } "%.3e" sprintf ] call = ] unit-test +[ t ] [ "1.234567e+08" { 123456700 } "%e" sprintf = ] unit-test -[ t ] [ "2.5e-03" [ { 0.0025 } "%e" sprintf ] call = ] unit-test +[ t ] [ "3.625e+08" { 362525200 } "%.3e" sprintf = ] unit-test -[ t ] [ "2.5E-03" [ { 0.0025 } "%E" sprintf ] call = ] unit-test +[ t ] [ "2.5e-03" { 0.0025 } "%e" sprintf = ] unit-test -[ t ] [ "ff" [ { HEX: ff } "%x" sprintf ] call = ] unit-test +[ t ] [ "2.5E-03" { 0.0025 } "%E" sprintf = ] unit-test -[ t ] [ "FF" [ { HEX: ff } "%X" sprintf ] call = ] unit-test +[ t ] [ "ff" { HEX: ff } "%x" sprintf = ] unit-test -[ t ] [ "0f" [ { HEX: f } "%02x" sprintf ] call = ] unit-test +[ t ] [ "FF" { HEX: ff } "%X" sprintf = ] unit-test -[ t ] [ "0F" [ { HEX: f } "%02X" sprintf ] call = ] unit-test +[ t ] [ "0f" { HEX: f } "%02x" sprintf = ] unit-test + +[ t ] [ "0F" { HEX: f } "%02X" sprintf = ] unit-test [ t ] [ "2008-09-10" - [ { 2008 9 10 } "%04d-%02d-%02d" sprintf ] call = ] unit-test + { 2008 9 10 } "%04d-%02d-%02d" sprintf = ] unit-test [ t ] [ "Hello, World!" - [ { "Hello, World!" } "%s" sprintf ] call = ] unit-test + { "Hello, World!" } "%s" sprintf = ] unit-test [ t ] [ "printf test" - [ { } "printf test" sprintf ] call = ] unit-test + { } "printf test" sprintf = ] unit-test [ t ] [ "char a = 'a'" - [ { CHAR: a } "char %c = 'a'" sprintf ] call = ] unit-test + { CHAR: a } "char %c = 'a'" sprintf = ] unit-test -[ t ] [ "00" [ { HEX: 0 } "%02x" sprintf ] call = ] unit-test +[ t ] [ "00" { HEX: 0 } "%02x" sprintf = ] unit-test -[ t ] [ "ff" [ { HEX: ff } "%02x" sprintf ] call = ] unit-test +[ t ] [ "ff" { HEX: ff } "%02x" sprintf = ] unit-test [ t ] [ "0 message(s)" - [ { 0 "message" } "%d %s(s)%" sprintf ] call = ] unit-test + { 0 "message" } "%d %s(s)%" sprintf = ] unit-test [ t ] [ "0 message(s) with %" - [ { 0 "message" } "%d %s(s) with %%" sprintf ] call = ] unit-test + { 0 "message" } "%d %s(s) with %%" sprintf = ] unit-test [ t ] [ "justif: \"left \"" - [ { "left" } "justif: \"%-10s\"" sprintf ] call = ] unit-test + { "left" } "justif: \"%-10s\"" sprintf = ] unit-test [ t ] [ "justif: \" right\"" - [ { "right" } "justif: \"%10s\"" sprintf ] call = ] unit-test + { "right" } "justif: \"%10s\"" sprintf = ] unit-test [ t ] [ " 3: 0003 zero padded" - [ { 3 } " 3: %04d zero padded" sprintf ] call = ] unit-test + { 3 } " 3: %04d zero padded" sprintf = ] unit-test [ t ] [ " 3: 3 left justif" - [ { 3 } " 3: %-4d left justif" sprintf ] call = ] unit-test + { 3 } " 3: %-4d left justif" sprintf = ] unit-test [ t ] [ " 3: 3 right justif" - [ { 3 } " 3: %4d right justif" sprintf ] call = ] unit-test + { 3 } " 3: %4d right justif" sprintf = ] unit-test [ t ] [ " -3: -003 zero padded" - [ { -3 } " -3: %04d zero padded" sprintf ] call = ] unit-test + { -3 } " -3: %04d zero padded" sprintf = ] unit-test [ t ] [ " -3: -3 left justif" - [ { -3 } " -3: %-4d left justif" sprintf ] call = ] unit-test + { -3 } " -3: %-4d left justif" sprintf = ] unit-test [ t ] [ " -3: -3 right justif" - [ { -3 } " -3: %4d right justif" sprintf ] call = ] unit-test + { -3 } " -3: %4d right justif" sprintf = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - [ { 10 "kitchen" } "There are %d monkeys in the %s" sprintf ] call = ] unit-test + { 10 "kitchen" } "There are %d monkeys in the %s" sprintf = ] unit-test -[ f ] [ "%d" [ { 10 } "%d" sprintf ] call = ] unit-test +[ f ] [ "%d" { 10 } "%d" sprintf = ] unit-test + +[ t ] [ "[monkey]" { "monkey" } "[%s]" sprintf = ] unit-test + +[ t ] [ "[ monkey]" { "monkey" } "[%10s]" sprintf = ] unit-test + +[ t ] [ "[monkey ]" { "monkey" } "[%-10s]" sprintf = ] unit-test + +[ t ] [ "[0000monkey]" { "monkey" } "[%010s]" sprintf = ] unit-test + +[ t ] [ "[####monkey]" { "monkey" } "[%'#10s]" sprintf = ] unit-test + +[ t ] [ "[many monke]" { "many monkeys" } "[%10.10s]" sprintf = ] unit-test -[ t ] [ "[monkey]" [ { "monkey" } "[%s]" sprintf ] call = ] unit-test -[ t ] [ "[ monkey]" [ { "monkey" } "[%10s]" sprintf ] call = ] unit-test -[ t ] [ "[monkey ]" [ { "monkey" } "[%-10s]" sprintf ] call = ] unit-test -[ t ] [ "[0000monkey]" [ { "monkey" } "[%010s]" sprintf ] call = ] unit-test -[ t ] [ "[####monkey]" [ { "monkey" } "[%'#10s]" sprintf ] call = ] unit-test -[ t ] [ "[many monke]" [ { "many monkeys" } "[%10.10s]" sprintf ] call = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index f46d08adfa..b24e58d6cc 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: io io.encodings.ascii io.files -kernel sequences strings vectors math math.parser macros +USING: io io.encodings.ascii io.files io.streams.string +kernel sequences splitting strings vectors math math.parser macros fry peg.ebnf unicode.case arrays prettyprint quotations ; IN: printf @@ -15,11 +15,8 @@ IN: printf : write-all ( seq -- quot ) [ [ write ] append ] map ; -: append-all ( seq -- string ) - SBUF" " [ dip swap append ] reduce ; - : apply-format ( params quot -- params string ) - [ dup pop ] dip call ; + [ dup pop ] dip call ; inline : fix-neg ( string -- string ) dup CHAR: 0 swap index 0 = @@ -28,14 +25,13 @@ IN: printf [ drop ] if ] when ; : >digits ( string -- digits ) - dup length 0 > [ >string string>number ] [ drop 0 ] if ; + [ 0 ] [ string>number ] if-empty ; -: zero-pad ( string digits -- string ) - swap dup - CHAR: . swap index rot + 1+ - dup rot swap - CHAR: 0 pad-right - swap head-slice ; +: max-digits ( string digits -- string ) + [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; + +: max-width ( string length -- string ) + [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; : >exponential ( n -- base exp ) 0 @@ -49,8 +45,6 @@ IN: printf [ 0 < [ "-" ] [ "+" ] if ] dip append "e" prepend ; -PRIVATE> - EBNF: parse-format-string plain-text = (!("%").)+ => [[ >string 1quotation ]] @@ -62,31 +56,31 @@ pad-char = "'" (.) => [[ second ]] pad-char_ = (pad-zero|pad-char)? => [[ CHAR: \s or 1quotation ]] pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] -pad = (pad-align) (pad-char_) (pad-width) => [[ reverse compose-all ]] +pad = pad-align pad-char_ pad-width => [[ reverse compose-all ]] -width = "." ([0-9])* => [[ second >digits '[ _ head-slice ] ]] +width = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width_ = (width)? => [[ [ ] or ]] -digits = "." ([0-9])* => [[ second >digits '[ _ zero-pad ] ]] +digits = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] digits_ = (digits)? => [[ [ ] or ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] -chars = (fmt-c|fmt-C) => [[ '[ _ apply-format ] ]] +chars = (fmt-c | fmt-C) => [[ '[ _ apply-format ] ]] fmt-s = "s" => [[ [ ] ]] fmt-S = "S" => [[ [ >upper ] ]] -strings = (pad) (width_) (fmt-s|fmt-S) => [[ reverse compose-all '[ _ apply-format ] ]] +strings = pad width_ (fmt-s | fmt-S) => [[ reverse compose-all '[ _ apply-format ] ]] fmt-d = "d" => [[ [ >fixnum number>string ] ]] decimals = fmt-d fmt-e = "e" => [[ [ >exponential ] ]] fmt-E = "E" => [[ [ >exponential >upper ] ]] -exps = (digits_) (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] +exps = digits_ (fmt-e | fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] fmt-f = "f" => [[ [ >float number>string ] ]] -floats = (digits_) (fmt-f) => [[ reverse compose-all ]] +floats = digits_ fmt-f => [[ reverse compose-all ]] fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] @@ -96,21 +90,18 @@ numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg formats = "%" (chars|strings|numbers|percents) => [[ second ]] -text = (formats|plain-text)* +text = (formats|plain-text)* => [[ write-all compose-all ]] ;EBNF +PRIVATE> + MACRO: printf ( format-string -- ) - parse-format-string - '[ reverse >vector _ write-all compose-all call drop ] ; - -MACRO: sprintf ( format-string -- ) - parse-format-string - '[ reverse >vector _ append-all >string swap drop ] ; - -MACRO: fprintf ( format-string -- ) - parse-format-string - '[ reverse >vector _ write-all compose-all rot ascii [ call ] with-file-appender drop ] ; + parse-format-string '[ reverse >vector @ drop ] ; +: sprintf ( params format-string -- result ) + [ printf ] with-string-writer ; +: fprintf ( filename params format-string -- ) + rot ascii [ printf ] with-file-appender ; From 53197ddb1b03ddc1564e6922bde4aac42ca47971 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 10:59:44 -0700 Subject: [PATCH 15/38] Adding more docs for printf. --- extra/printf/printf-docs.factor | 37 +++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index c1638f0d23..21981b8b4a 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -6,20 +6,35 @@ IN: printf HELP: printf { $values { "format-string" string } } { $description - "Writes the arguments formatted according to the format string." + "Writes the arguments formatted according to the format string.\n" { $table { "%%" "Single %" "" } - { "%Wd" "Integer W digits wide (e.g., \"1234\")" "fixnum" } - { "%W.De" "Scientific notation" "fixnum, float" } - { "%W.DE" "Scientific notation" "fixnum, float" } - { "%W.Df" "Fixed format" "fixnum, float" } - { "%Wx" "Hexadecimal" "hex" } - { "%WX" "Hexadecimal uppercase" "hex" } - { "%W.Ds" "String format" "string" } - { "%W.DS" "String format uppercase" "string" } + { "%Pd" "Integer format" "fixnum" } + { "%P.De" "Scientific notation" "fixnum, float" } + { "%P.DE" "Scientific notation" "fixnum, float" } + { "%P.Df" "Fixed format" "fixnum, float" } + { "%Px" "Hexadecimal" "hex" } + { "%PX" "Hexadecimal uppercase" "hex" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } { "%c" "Character format" "char" } { "%C" "Character format uppercase" "char" } } + "\n" + "Padding ('P') is used to specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" + { $list + "\"%5s\" formats a string padding with spaces up to 5 characters wide." + "\"%08d\" formats an integer padding with zeros up to 3 characters wide." + "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." + "\"%-10d\" formats an integer to 10 characters wide and left-aligns." + } + "\n" + "Digits ('D') is used to specify the maximum digits in the result string. For example:\n" + { $list + "\"%.3s\" formats a string to truncate at 3 characters (from the left)." + "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." + } } { $examples { $example @@ -38,6 +53,10 @@ HELP: printf "USING: printf ;" "{ 1234567890 } \"%.5e\" printf" "1.23456e+09" } + { $example + "USING: printf ;" + "{ 12 } \"%'#4d\" printf" + "##12" } } ; HELP: sprintf From 5885a924fc2cce6bfb8bd9f9b0c031cc37bdfe94 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 19:59:22 -0700 Subject: [PATCH 16/38] Changing printf to use arguments from the stack. --- extra/printf/printf-docs.factor | 10 ++--- extra/printf/printf-tests.factor | 76 ++++++++++++++++---------------- extra/printf/printf.factor | 60 ++++++++++--------------- 3 files changed, 67 insertions(+), 79 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index 21981b8b4a..ca26337026 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -39,23 +39,23 @@ HELP: printf { $examples { $example "USING: printf ;" - "{ 123 } \"%05d\" printf" + "123 \"%05d\" printf" "00123" } { $example "USING: printf ;" - "{ HEX: ff } \"04X\" printf" + "HEX: ff \"04X\" printf" "00FF" } { $example "USING: printf ;" - "{ 1.23456789 } \"%.3f\" printf" + "1.23456789 \"%.3f\" printf" "1.234" } { $example "USING: printf ;" - "{ 1234567890 } \"%.5e\" printf" + "1234567890 \"%.5e\" printf" "1.23456e+09" } { $example "USING: printf ;" - "{ 12 } \"%'#4d\" printf" + "12 \"%'#4d\" printf" "##12" } } ; diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 7d89b35ae9..9a608cbffc 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -5,96 +5,96 @@ USING: kernel printf tools.test ; [ "%s" printf ] must-infer -[ t ] [ "10" { 10 } "%d" sprintf = ] unit-test +[ t ] [ "10" 10 "%d" sprintf = ] unit-test -[ t ] [ "123.456" { 123.456 } "%f" sprintf = ] unit-test +[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test -[ t ] [ "123.10" { 123.1 } "%01.2f" sprintf = ] unit-test +[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test -[ t ] [ "1.2345" { 1.23456789 } "%.4f" sprintf = ] unit-test +[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test -[ t ] [ " 1.23" { 1.23456789 } "%6.2f" sprintf = ] unit-test +[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test -[ t ] [ "1.234e+08" { 123400000 } "%e" sprintf = ] unit-test +[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test -[ t ] [ "1.234567e+08" { 123456700 } "%e" sprintf = ] unit-test +[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test -[ t ] [ "3.625e+08" { 362525200 } "%.3e" sprintf = ] unit-test +[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test -[ t ] [ "2.5e-03" { 0.0025 } "%e" sprintf = ] unit-test +[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test -[ t ] [ "2.5E-03" { 0.0025 } "%E" sprintf = ] unit-test +[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test -[ t ] [ "ff" { HEX: ff } "%x" sprintf = ] unit-test +[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test -[ t ] [ "FF" { HEX: ff } "%X" sprintf = ] unit-test +[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test -[ t ] [ "0f" { HEX: f } "%02x" sprintf = ] unit-test +[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test -[ t ] [ "0F" { HEX: f } "%02X" sprintf = ] unit-test +[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test [ t ] [ "2008-09-10" - { 2008 9 10 } "%04d-%02d-%02d" sprintf = ] unit-test + 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test [ t ] [ "Hello, World!" - { "Hello, World!" } "%s" sprintf = ] unit-test + "Hello, World!" "%s" sprintf = ] unit-test [ t ] [ "printf test" - { } "printf test" sprintf = ] unit-test + "printf test" sprintf = ] unit-test [ t ] [ "char a = 'a'" - { CHAR: a } "char %c = 'a'" sprintf = ] unit-test + CHAR: a "char %c = 'a'" sprintf = ] unit-test -[ t ] [ "00" { HEX: 0 } "%02x" sprintf = ] unit-test +[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test -[ t ] [ "ff" { HEX: ff } "%02x" sprintf = ] unit-test +[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test [ t ] [ "0 message(s)" - { 0 "message" } "%d %s(s)%" sprintf = ] unit-test + 0 "message" "%d %s(s)" sprintf = ] unit-test [ t ] [ "0 message(s) with %" - { 0 "message" } "%d %s(s) with %%" sprintf = ] unit-test + 0 "message" "%d %s(s) with %%" sprintf = ] unit-test [ t ] [ "justif: \"left \"" - { "left" } "justif: \"%-10s\"" sprintf = ] unit-test + "left" "justif: \"%-10s\"" sprintf = ] unit-test [ t ] [ "justif: \" right\"" - { "right" } "justif: \"%10s\"" sprintf = ] unit-test + "right" "justif: \"%10s\"" sprintf = ] unit-test [ t ] [ " 3: 0003 zero padded" - { 3 } " 3: %04d zero padded" sprintf = ] unit-test + 3 " 3: %04d zero padded" sprintf = ] unit-test [ t ] [ " 3: 3 left justif" - { 3 } " 3: %-4d left justif" sprintf = ] unit-test + 3 " 3: %-4d left justif" sprintf = ] unit-test [ t ] [ " 3: 3 right justif" - { 3 } " 3: %4d right justif" sprintf = ] unit-test + 3 " 3: %4d right justif" sprintf = ] unit-test [ t ] [ " -3: -003 zero padded" - { -3 } " -3: %04d zero padded" sprintf = ] unit-test + -3 " -3: %04d zero padded" sprintf = ] unit-test [ t ] [ " -3: -3 left justif" - { -3 } " -3: %-4d left justif" sprintf = ] unit-test + -3 " -3: %-4d left justif" sprintf = ] unit-test [ t ] [ " -3: -3 right justif" - { -3 } " -3: %4d right justif" sprintf = ] unit-test + -3 " -3: %4d right justif" sprintf = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - { 10 "kitchen" } "There are %d monkeys in the %s" sprintf = ] unit-test + 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test -[ f ] [ "%d" { 10 } "%d" sprintf = ] unit-test +[ f ] [ "%d" 10 "%d" sprintf = ] unit-test -[ t ] [ "[monkey]" { "monkey" } "[%s]" sprintf = ] unit-test +[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test -[ t ] [ "[ monkey]" { "monkey" } "[%10s]" sprintf = ] unit-test +[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test -[ t ] [ "[monkey ]" { "monkey" } "[%-10s]" sprintf = ] unit-test +[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test -[ t ] [ "[0000monkey]" { "monkey" } "[%010s]" sprintf = ] unit-test +[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test -[ t ] [ "[####monkey]" { "monkey" } "[%'#10s]" sprintf = ] unit-test +[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test -[ t ] [ "[many monke]" { "many monkeys" } "[%10.10s]" sprintf = ] unit-test +[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index b24e58d6cc..4c66db3661 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license USING: io io.encodings.ascii io.files io.streams.string -kernel sequences splitting strings vectors math math.parser macros -fry peg.ebnf unicode.case arrays prettyprint quotations ; +kernel sequences splitting strings math math.parser macros +fry peg.ebnf unicode.case arrays quotations vectors ; IN: printf @@ -12,12 +12,6 @@ IN: printf : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; -: write-all ( seq -- quot ) - [ [ write ] append ] map ; - -: apply-format ( params quot -- params string ) - [ dup pop ] dip call ; inline - : fix-neg ( string -- string ) dup CHAR: 0 swap index 0 = [ dup CHAR: - swap index dup @@ -47,61 +41,55 @@ IN: printf EBNF: parse-format-string -plain-text = (!("%").)+ => [[ >string 1quotation ]] +zero = "0" => [[ CHAR: 0 ]] +char = "'" (.) => [[ second ]] -percents = "%" => [[ '[ "%" ] ]] - -pad-zero = "0" => [[ CHAR: 0 ]] -pad-char = "'" (.) => [[ second ]] -pad-char_ = (pad-zero|pad-char)? => [[ CHAR: \s or 1quotation ]] +pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]] pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] -pad = pad-align pad-char_ pad-width => [[ reverse compose-all ]] +pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] -width = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] -width_ = (width)? => [[ [ ] or ]] +width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] +width = (width_)? => [[ [ ] or ]] -digits = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] -digits_ = (digits)? => [[ [ ] or ]] +digits_ = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] +digits = (digits_)? => [[ [ ] or ]] +fmt-% = "%" => [[ [ "%" ] ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] -chars = (fmt-c | fmt-C) => [[ '[ _ apply-format ] ]] - fmt-s = "s" => [[ [ ] ]] fmt-S = "S" => [[ [ >upper ] ]] -strings = pad width_ (fmt-s | fmt-S) => [[ reverse compose-all '[ _ apply-format ] ]] - fmt-d = "d" => [[ [ >fixnum number>string ] ]] -decimals = fmt-d - fmt-e = "e" => [[ [ >exponential ] ]] fmt-E = "E" => [[ [ >exponential >upper ] ]] -exps = digits_ (fmt-e | fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] - fmt-f = "f" => [[ [ >float number>string ] ]] -floats = digits_ fmt-f => [[ reverse compose-all ]] - fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] +unknown = (.)* => [[ "Unknown directive" throw ]] + +chars = fmt-c | fmt-C +strings = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]] +decimals = fmt-d +exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] +floats = digits fmt-f => [[ reverse compose-all ]] hex = fmt-x | fmt-X +numbers = pad (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append ]] -numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append '[ _ apply-format ] ]] +formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] -formats = "%" (chars|strings|numbers|percents) => [[ second ]] +plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] -text = (formats|plain-text)* => [[ write-all compose-all ]] +text = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]] ;EBNF PRIVATE> MACRO: printf ( format-string -- ) - parse-format-string '[ reverse >vector @ drop ] ; + parse-format-string [ length ] keep compose-all '[ _ @ reverse [ write ] each ] ; -: sprintf ( params format-string -- result ) +: sprintf ( format-string -- ) [ printf ] with-string-writer ; -: fprintf ( filename params format-string -- ) - rot ascii [ printf ] with-file-appender ; From e966330bbb8ef5ce7759b2bfaffa8020db8d9db6 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 23:11:02 -0700 Subject: [PATCH 17/38] printf: Allow positive sign to prefix numbers, add more tests, fix negative numbers in exponentials. --- extra/printf/printf-tests.factor | 24 ++++++++++++++++++++++++ extra/printf/printf.factor | 30 ++++++++++++++++++++---------- 2 files changed, 44 insertions(+), 10 deletions(-) diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 9a608cbffc..084553c54d 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -7,6 +7,16 @@ USING: kernel printf tools.test ; [ t ] [ "10" 10 "%d" sprintf = ] unit-test +[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test + +[ t ] [ "-10" -10 "%d" sprintf = ] unit-test + +[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test + +[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test + +[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test + [ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test [ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test @@ -17,6 +27,8 @@ USING: kernel printf tools.test ; [ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test +[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test + [ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test [ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test @@ -25,6 +37,18 @@ USING: kernel printf tools.test ; [ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test +[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test + +[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test + +[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test + +[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test + +[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test + +[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test + [ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test [ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 4c66db3661..346a344093 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: io io.encodings.ascii io.files io.streams.string +USING: io io.encodings.ascii io.files io.streams.string combinators kernel sequences splitting strings math math.parser macros -fry peg.ebnf unicode.case arrays quotations vectors ; +fry peg.ebnf ascii unicode.case arrays quotations vectors ; IN: printf @@ -12,11 +12,17 @@ IN: printf : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; -: fix-neg ( string -- string ) +: fix-sign ( string -- string ) dup CHAR: 0 swap index 0 = - [ dup CHAR: - swap index dup - [ swap remove-nth "-" prepend ] - [ drop ] if ] when ; + [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from + [ dup 1- rot dup [ nth ] dip swap + { + { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] } + { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] } + [ drop swap drop ] + } case + ] [ drop ] if + ] when ; : >digits ( string -- digits ) [ 0 ] [ string>number ] if-empty ; @@ -28,16 +34,18 @@ IN: printf [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; : >exponential ( n -- base exp ) + [ 0 < ] keep abs 0 - [ swap dup [ 10.0 > ] keep 1.0 < or ] - [ dup 10.0 > + [ swap dup [ 10.0 >= ] keep 1.0 < or ] + [ dup 10.0 >= [ 10.0 / [ 1+ ] dip swap ] [ 10.0 * [ 1- ] dip swap ] if ] [ swap ] while [ number>string ] dip dup abs number>string 2 CHAR: 0 pad-left [ 0 < [ "-" ] [ "+" ] if ] dip append - "e" prepend ; + "e" prepend + rot [ [ "-" prepend ] dip ] when ; EBNF: parse-format-string @@ -49,6 +57,8 @@ pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] +sign = ("+")? => [[ [ [ dup CHAR: - swap index not [ "+" prepend ] when ] ] [ [ ] ] if ]] + width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width = (width_)? => [[ [ ] or ]] @@ -74,7 +84,7 @@ decimals = fmt-d exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] floats = digits fmt-f => [[ reverse compose-all ]] hex = fmt-x | fmt-X -numbers = pad (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append ]] +numbers = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]] formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] From 37aaaf141683be563578cd64d03b69b4e9b87ee8 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 18 Sep 2008 12:26:26 -0700 Subject: [PATCH 18/38] Updated printf docs. --- extra/printf/printf-docs.factor | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index ca26337026..5025fa421f 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -9,19 +9,21 @@ HELP: printf "Writes the arguments formatted according to the format string.\n" { $table { "%%" "Single %" "" } - { "%Pd" "Integer format" "fixnum" } - { "%P.De" "Scientific notation" "fixnum, float" } - { "%P.DE" "Scientific notation" "fixnum, float" } - { "%P.Df" "Fixed format" "fixnum, float" } - { "%Px" "Hexadecimal" "hex" } - { "%PX" "Hexadecimal uppercase" "hex" } { "%P.Ds" "String format" "string" } { "%P.DS" "String format uppercase" "string" } { "%c" "Character format" "char" } { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } } "\n" - "Padding ('P') is used to specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" + "A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." + "\n" + "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" { $list "\"%5s\" formats a string padding with spaces up to 5 characters wide." "\"%08d\" formats an integer padding with zeros up to 3 characters wide." @@ -29,7 +31,7 @@ HELP: printf "\"%-10d\" formats an integer to 10 characters wide and left-aligns." } "\n" - "Digits ('D') is used to specify the maximum digits in the result string. For example:\n" + "Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" { $list "\"%.3s\" formats a string to truncate at 3 characters (from the left)." "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." @@ -57,6 +59,10 @@ HELP: printf "USING: printf ;" "12 \"%'#4d\" printf" "##12" } + { $example + "USING: printf ;" + "1234 \"%+d\" printf" + "+1234" } } ; HELP: sprintf From edc1a27fcd77525aef0591820b3052c2d03343ed Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 18 Sep 2008 15:18:32 -0700 Subject: [PATCH 19/38] Adding a summary for printf. --- extra/printf/summary.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/printf/summary.txt diff --git a/extra/printf/summary.txt b/extra/printf/summary.txt new file mode 100644 index 0000000000..da1aa31abb --- /dev/null +++ b/extra/printf/summary.txt @@ -0,0 +1 @@ +Format data according to a specified format string, and writes (or returns) the result string. From d9e0060eb820d0b21997ade7d5dd917fb0f20aed Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 19 Sep 2008 22:14:00 -0300 Subject: [PATCH 20/38] irc.messages: Fix `_' word conflict between fry and inverse --- extra/irc/messages/messages.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 94f80dcf0c..9201f822da 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,9 +1,10 @@ ! 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 inverse ; + arrays classes.tuple math.order ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; +EXCLUDE: inverse => _ ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; @@ -69,8 +70,8 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ [ 2array ] dip ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ [ 3array ] dip ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> @@ -94,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string ) ! ====================================== : split-at-first ( seq separators -- before after ) - dupd '[ _ member? ] find - [ cut 1 tail ] - [ swap ] - if ; + dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ; : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; From 6d2a25efc3648b5b6840fbeccb779bf16c98e16e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 21:46:35 -0700 Subject: [PATCH 21/38] Some simplification to printf, more to come. --- extra/printf/printf.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 346a344093..2f23085644 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -31,11 +31,10 @@ IN: printf [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; : max-width ( string length -- string ) - [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; + short head ; : >exponential ( n -- base exp ) - [ 0 < ] keep abs - 0 + [ 0 < ] keep abs 0 [ swap dup [ 10.0 >= ] keep 1.0 < or ] [ dup 10.0 >= [ 10.0 / [ 1+ ] dip swap ] @@ -43,7 +42,7 @@ IN: printf ] [ swap ] while [ number>string ] dip dup abs number>string 2 CHAR: 0 pad-left - [ 0 < [ "-" ] [ "+" ] if ] dip append + [ 0 < "-" "+" ? ] dip append "e" prepend rot [ [ "-" prepend ] dip ] when ; @@ -53,11 +52,11 @@ zero = "0" => [[ CHAR: 0 ]] char = "'" (.) => [[ second ]] pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]] -pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] +pad-align = ("-")? => [[ [ pad-right ] [ pad-left ] ? ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] -sign = ("+")? => [[ [ [ dup CHAR: - swap index not [ "+" prepend ] when ] ] [ [ ] ] if ]] +sign = ("+")? => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]] width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width = (width_)? => [[ [ ] or ]] From 7cbbd3e0e68aa9a259239957c2227839f66b36a3 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:22:12 -0700 Subject: [PATCH 22/38] Some fixes to printf for help-lint warnings. --- extra/printf/printf-docs.factor | 8 ++++---- extra/printf/printf-tests.factor | 2 ++ extra/printf/printf.factor | 4 ++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index 5025fa421f..fabf6d1ddd 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -6,7 +6,7 @@ IN: printf HELP: printf { $values { "format-string" string } } { $description - "Writes the arguments formatted according to the format string.\n" + "Writes the arguments (specified on the stack) formatted according to the format string.\n" { $table { "%%" "Single %" "" } { "%P.Ds" "String format" "string" } @@ -45,7 +45,7 @@ HELP: printf "00123" } { $example "USING: printf ;" - "HEX: ff \"04X\" printf" + "HEX: ff \"%04X\" printf" "00FF" } { $example "USING: printf ;" @@ -66,7 +66,7 @@ HELP: printf } ; HELP: sprintf -{ $values { "params" sequence } { "format-string" string } { "result" string } } -{ $description "Returns the arguments formatted according to the format string as a result string." } +{ $values { "format-string" string } { "result" string } } +{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } { $see-also printf } ; diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 084553c54d..b365343bf0 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -5,6 +5,8 @@ USING: kernel printf tools.test ; [ "%s" printf ] must-infer +[ "%s" sprintf ] must-infer + [ t ] [ "10" 10 "%d" sprintf = ] unit-test [ t ] [ "+10" 10 "%+d" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 2f23085644..c7a7153d6a 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -98,7 +98,7 @@ PRIVATE> MACRO: printf ( format-string -- ) parse-format-string [ length ] keep compose-all '[ _ @ reverse [ write ] each ] ; -: sprintf ( format-string -- ) - [ printf ] with-string-writer ; +: sprintf ( format-string -- result ) + [ printf ] with-string-writer ; inline From 2d5778c5af7c0f36a0f2973775fab32beb6dc955 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:39:12 -0700 Subject: [PATCH 23/38] Moving format specifications to a help article. --- extra/printf/printf-docs.factor | 68 +++++++++++++++++---------------- 1 file changed, 35 insertions(+), 33 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index fabf6d1ddd..a6f18cef8e 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -5,39 +5,7 @@ IN: printf HELP: printf { $values { "format-string" string } } -{ $description - "Writes the arguments (specified on the stack) formatted according to the format string.\n" - { $table - { "%%" "Single %" "" } - { "%P.Ds" "String format" "string" } - { "%P.DS" "String format uppercase" "string" } - { "%c" "Character format" "char" } - { "%C" "Character format uppercase" "char" } - { "%+Pd" "Integer format" "fixnum" } - { "%+P.De" "Scientific notation" "fixnum, float" } - { "%+P.DE" "Scientific notation" "fixnum, float" } - { "%+P.Df" "Fixed format" "fixnum, float" } - { "%+Px" "Hexadecimal" "hex" } - { "%+PX" "Hexadecimal uppercase" "hex" } - } - "\n" - "A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." - "\n" - "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" - { $list - "\"%5s\" formats a string padding with spaces up to 5 characters wide." - "\"%08d\" formats an integer padding with zeros up to 3 characters wide." - "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." - "\"%-10d\" formats an integer to 10 characters wide and left-aligns." - } - "\n" - "Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" - { $list - "\"%.3s\" formats a string to truncate at 3 characters (from the left)." - "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." - "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." - } -} +{ $description "Writes the arguments (specified on the stack) formatted according to the format string." } { $examples { $example "USING: printf ;" @@ -70,3 +38,37 @@ HELP: sprintf { $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } { $see-also printf } ; +ARTICLE: "printf" "Formatted printing" +"The " { $vocab-link "printf" } " and " { $vocab-link "sprintf" } " words are used for formatted printing.\n" +"\n" +"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n" +{ $table + { "%%" "Single %" "" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } +} +"\n" +"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." +"\n" +"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" +{ $list + "\"%5s\" formats a string padding with spaces up to 5 characters wide." + "\"%08d\" formats an integer padding with zeros up to 3 characters wide." + "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." + "\"%-10d\" formats an integer to 10 characters wide and left-aligns." +} +"\n" +"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" +{ $list + "\"%.3s\" formats a string to truncate at 3 characters (from the left)." + "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." +} ; From a9f2fbd4a2a7e62af25e9ed55b8a315ac5503024 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:41:16 -0700 Subject: [PATCH 24/38] Fix newline. --- extra/printf/printf-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index a6f18cef8e..fdecc2ad68 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "printf" "Formatted printing" { "%+PX" "Hexadecimal uppercase" "hex" } } "\n" -"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." +"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n" "\n" "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" { $list From 6032bdf8e664093e8e0d2b5c6f6c970a34b84af0 Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Sat, 12 Apr 2008 19:10:34 +0300 Subject: [PATCH 25/38] first efforts to get indentation in emacs --- misc/factor.el | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 5c9d050468..af6ec6c95c 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -111,6 +111,7 @@ (use-local-map factor-mode-map) (setq major-mode 'factor-mode) (setq mode-name "Factor") + (set (make-local-variable 'indent-line-function) #'factor-indent-line) (make-local-variable 'comment-start) (setq comment-start "! ") (make-local-variable 'font-lock-defaults) @@ -224,6 +225,48 @@ (define-key factor-mode-map "\C-c\C-h" 'factor-help) (define-key factor-mode-map "\C-cc" 'comment-region) (define-key factor-mode-map [return] 'newline-and-indent) +(define-key factor-mode-map [tab] 'indent-for-tab-command) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-indent-line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun factor-calculate-indentation () + "Calculate Factor indentation for line at point." + (let ((not-indented t) + (cur-indent 0)) + (save-excursion + (beginning-of-line) + (if (bobp) + (setq cur-indent 0) + (save-excursion + (while not-indented + (forward-line -1) + ;; Check that we are after the end of previous word + (if (looking-at ".*;[ \t]*$") + (progn + (setq cur-indent (- (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (looking-at "^\\(\\|:\\): ") + (progn + (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (bobp) + (setq not-indented nil)))))))) + cur-indent)) + +(defun factor-indent-line () + "Indent current line as Factor code" + (let ((target (factor-calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; factor-listener-mode @@ -244,5 +287,3 @@ (defun factor-refresh-all () (interactive) (comint-send-string "*factor*" "refresh-all\n")) - - From 22c10e8f4f133f043e6106e9de65d466db7da133 Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Mon, 28 Apr 2008 23:36:54 +0300 Subject: [PATCH 26/38] Got Emacs' factor-mode indentation working with non-closed brackets --- misc/factor.el | 40 ++++++++++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index af6ec6c95c..402dfdf484 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -76,7 +76,7 @@ (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) (defvar factor-mode-map (make-sparse-keymap)) - + (defcustom factor-mode-hook nil "Hook run when entering Factor mode." :type 'hook @@ -211,7 +211,7 @@ (defun factor-clear () (interactive) (factor-send-string "clear")) - + (defun factor-comment-line () (interactive) (beginning-of-line) @@ -241,19 +241,35 @@ (setq cur-indent 0) (save-excursion (while not-indented - (forward-line -1) - ;; Check that we are after the end of previous word - (if (looking-at ".*;[ \t]*$") + ;; Check that we are inside open brackets + (if (> (factor-brackets-depth) 0) (progn - (setq cur-indent (- (current-indentation) default-tab-width)) - (setq not-indented nil)) - (if (looking-at "^\\(\\|:\\): ") + (let ((cur-depth (factor-brackets-depth))) + (forward-line -1) + (setq cur-indent (+ (current-indentation) + (* default-tab-width + (- cur-depth (factor-brackets-depth))))) + (setq not-indented nil))) + (forward-line -1) + ;; Check that we are after the end of previous word + (if (looking-at ".*;[ \t]*$") (progn - (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq cur-indent (- (current-indentation) default-tab-width)) (setq not-indented nil)) - (if (bobp) - (setq not-indented nil)))))))) - cur-indent)) + ;; Check that we are after the start of word + (if (looking-at "^\\(\\|:\\): ") + (progn + (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (bobp) + (setq not-indented nil))))))))) + cur-indent)) + +(defun factor-brackets-depth () + "Returns number of brackets, not closed on previous lines." + (syntax-ppss-depth + (save-excursion + (syntax-ppss (line-beginning-position))))) (defun factor-indent-line () "Indent current line as Factor code" From 83ef3149fe6739b7e623cfcf24098929110ae4ec Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Sun, 21 Sep 2008 18:42:48 +0300 Subject: [PATCH 27/38] Upgraded version of emacs indentation --- misc/factor.el | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 402dfdf484..1ae8919559 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -228,9 +228,17 @@ (define-key factor-mode-map [tab] 'indent-for-tab-command) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; factor-indent-line +;; indentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defconst factor-word-starting-keywords + '("" ":" "TUPLE" "MACRO" "MACRO:" "M")) + +(defmacro factor-word-start-re (keywords) + `(format + "^\\(%s\\): " + (mapconcat 'identity ,keywords "\\|"))) + (defun factor-calculate-indentation () "Calculate Factor indentation for line at point." (let ((not-indented t) @@ -242,27 +250,28 @@ (save-excursion (while not-indented ;; Check that we are inside open brackets - (if (> (factor-brackets-depth) 0) - (progn - (let ((cur-depth (factor-brackets-depth))) - (forward-line -1) - (setq cur-indent (+ (current-indentation) - (* default-tab-width - (- cur-depth (factor-brackets-depth))))) - (setq not-indented nil))) - (forward-line -1) + (save-excursion + (let ((cur-depth (factor-brackets-depth))) + (forward-line -1) + (setq cur-indent (+ (current-indentation) + (* default-tab-width + (- cur-depth (factor-brackets-depth))))) + (setq not-indented nil))) + (forward-line -1) ;; Check that we are after the end of previous word (if (looking-at ".*;[ \t]*$") (progn (setq cur-indent (- (current-indentation) default-tab-width)) (setq not-indented nil)) ;; Check that we are after the start of word - (if (looking-at "^\\(\\|:\\): ") + (if (looking-at (factor-word-start-re factor-word-starting-keywords)) +; (if (looking-at "^[A-Z:]*: ") (progn + (message "inword") (setq cur-indent (+ (current-indentation) default-tab-width)) (setq not-indented nil)) (if (bobp) - (setq not-indented nil))))))))) + (setq not-indented nil)))))))) cur-indent)) (defun factor-brackets-depth () From d256db22d19f99c4e433e69423a83b116eb879dd Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 21 Sep 2008 20:38:01 -0300 Subject: [PATCH 28/38] irc.client: Fixes, refactoring --- extra/irc/client/client-tests.factor | 2 +- extra/irc/client/client.factor | 84 ++++++++++++++++------------ 2 files changed, 50 insertions(+), 36 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 932bdda472..c768c1a82e 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- ) [ [ last-line>> concat ] [ lines>> ] bi push ] keep V{ } clone >>last-line drop ; -: spawn-client ( lines listeners -- irc-client ) +: spawn-client ( -- irc-client ) "someserver" irc-port "factorbot" f t >>is-running diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index db4fdd2a58..569f6c4bf7 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -68,12 +68,17 @@ 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 +> values [ out-messages>> ] map ] + [ in-messages>> ] + [ out-messages>> ] tri 2array prepend + [ irc-end swap mailbox-put ] each ; +PRIVATE> + : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri + [ end-loops ] [ [ f ] dip (>>is-running) ] bi ] when* ; [ stream-print ] keep stream-flush ; : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; - +: channel-mode? ( mode -- ? ) name>> first "#&" member? ; +: me? ( string -- ? ) irc> profile>> nickname>> = ; GENERIC: to-listener ( message obj -- ) @@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- ) swap dup listeners-with-participant [ rename-participant ] with with each ; : add-participant ( mode nick channel -- ) - listener> [ - [ participants>> set-at ] - [ [ +join+ f ] dip to-listener ] 2bi - ] [ 2drop ] if* ; + listener> + [ participants>> set-at ] + [ [ +join+ f ] dip to-listener ] 2bi ; + +: change-participant-mode ( channel mode nick -- ) + rot listener> + [ participants>> set-at ] + [ [ [ +mode+ ] dip ] dip to-listener ] 3bi ; ! FIXME DEFER: me? @@ -174,9 +184,6 @@ DEFER: me? ! Server message handling ! ====================================== -: me? ( string -- ? ) - irc> profile>> nickname>> = ; - GENERIC: forward-name ( irc-message -- name ) M: join forward-name ( join -- name ) trailing>> ; M: part forward-name ( part -- name ) channel>> ; @@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; M: join process-message ( join -- ) - [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; + [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri + dup listener> [ add-participant ] [ 3drop ] if ; M: part process-message ( part -- ) [ irc-message-sender ] [ channel>> ] bi remove-participant ; @@ -236,6 +244,12 @@ M: quit process-message ( quit -- ) M: nick process-message ( nick -- ) [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; +! M: mode process-message ( mode -- ) +! [ channel-mode? ] keep and [ +! [ name>> ] [ mode>> ] [ parameter>> ] tri +! [ change-participant-mode ] [ 2drop ] if* +! ] when* ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- ) [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -: handle-incoming-irc ( irc-message -- ) - [ forward-message ] [ process-message ] bi ; - ! ====================================== ! Client message handling ! ====================================== -: handle-outgoing-irc ( irc-message -- ) - irc-message>client-line irc-print ; +GENERIC: handle-outgoing-irc ( irc-message -- ? ) +M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ; +M: irc-message handle-outgoing-irc ( irc-message -- ? ) + irc-message>client-line irc-print t ; ! ====================================== ! Reader/Writer @@ -279,27 +292,28 @@ DEFER: (connect-irc) : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; -: (reader-loop) ( -- ) +: (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message + parse-irc-line handle-reader-message t ] [ - irc> terminate-irc + irc> terminate-irc f ] if* ] with-destructors ; : reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover t ; + [ (reader-loop) ] [ handle-disconnect t ] recover ; : writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc t ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ? ) - irc> in-messages>> mailbox-get handle-incoming-irc t ; + irc> in-messages>> mailbox-get + [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -310,22 +324,22 @@ DEFER: (connect-irc) [ nip ] } cond ; +GENERIC: handle-listener-out ( irc-message -- ? ) +M: irc-end handle-listener-out ( irc-end -- ? ) drop f ; +M: irc-message handle-listener-out ( irc-message -- ? ) + irc> out-messages>> mailbox-put t ; + : listener-loop ( name -- ? ) dup listener> [ out-messages>> mailbox-get - maybe-annotate-with-name - irc> out-messages>> mailbox-put - t + maybe-annotate-with-name handle-listener-out ] [ drop f ] if* ; -: spawn-irc-loop ( quot: ( -- ? ) name -- ) - [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip - spawn-server drop ; - : spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-irc-loop - [ writer-loop ] "irc-writer-loop" spawn-irc-loop - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ; + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; ! ====================================== ! Listener join request handling @@ -333,7 +347,7 @@ DEFER: (connect-irc) : set+run-listener ( name irc-listener -- ) over irc> listeners>> set-at - '[ _ listener-loop ] "listener" spawn-irc-loop ; + '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ; GENERIC: (add-listener) ( irc-listener -- ) From e9b30d2bbce0ee1dfcefadb63fe0b26385c6b639 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 21 Sep 2008 19:42:05 -0500 Subject: [PATCH 29/38] Debugging asides and conversation scope --- basis/furnace/actions/actions.factor | 2 +- basis/furnace/alloy/alloy.factor | 7 +- basis/furnace/asides/asides.factor | 111 ++++++++++++++++++ .../deactivate-user/deactivate-user.factor | 2 +- .../features/edit-profile/edit-profile.factor | 4 +- .../recover-password/recover-password.factor | 2 +- basis/furnace/auth/login/login.factor | 13 +- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- .../conversations/conversations.factor | 85 ++------------ basis/furnace/furnace.factor | 12 ++ basis/furnace/redirection/redirection.factor | 2 +- basis/furnace/sessions/sessions.factor | 4 + basis/furnace/syndication/syndication.factor | 4 +- 13 files changed, 160 insertions(+), 90 deletions(-) create mode 100644 basis/furnace/asides/asides.factor diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 6e55ca44a0..2a63489299 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ; begin-conversation nested-forms-key param " " split harvest nested-forms cset form get form cset - + ] [ <400> ] if* exit-with ; diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 6f5f6fdbf6..f27c7d67c0 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -3,6 +3,7 @@ USING: kernel sequences db.tuples alarms calendar db fry furnace.db furnace.cache +furnace.asides furnace.referrer furnace.sessions furnace.conversations @@ -12,17 +13,17 @@ IN: furnace.alloy : ( responder db params -- responder' ) '[ + _ _ ] call ; -: state-classes { session conversation permit } ; inline +: state-classes { session aside conversation permit user } ; inline : init-furnace-tables ( -- ) - state-classes ensure-tables - user ensure-table ; + state-classes ensure-tables ; : start-expiring ( db params -- ) '[ diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor new file mode 100644 index 0000000000..6d4196cf0b --- /dev/null +++ b/basis/furnace/asides/asides.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel sequences accessors hashtables +urls db.types db.tuples math.parser fry logging combinators +html.templates.chloe.syntax +http http.server http.server.filters http.server.redirection +furnace +furnace.cache +furnace.sessions +furnace.redirection ; +IN: furnace.asides + +TUPLE: aside < server-state +session method url post-data ; + +: