From 7acff0c906c22bd529bdde24dc4bd39b6705bfa4 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 09:32:17 -0300
Subject: [PATCH 01/24] irc.gitbot: Add formatting for topic change logs
---
extra/irc/client/base/base.factor | 2 +-
extra/irc/logbot/log-line/log-line.factor | 4 ++++
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor
index f54e18ac4b..318a1ab1e3 100644
--- a/extra/irc/client/base/base.factor
+++ b/extra/irc/client/base/base.factor
@@ -19,7 +19,7 @@ SYMBOL: current-irc-client
UNION: to-target privmsg notice ;
UNION: to-channel join part topic kick rpl-channel-modes
- rpl-notopic rpl-topic rpl-names rpl-names-end ;
+ topic rpl-names rpl-names-end ;
UNION: to-one-chat to-target to-channel mode ;
UNION: to-many-chats nick quit ;
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor
index b3af41ad3d..255c46e5f3 100644
--- a/extra/irc/logbot/log-line/log-line.factor
+++ b/extra/irc/logbot/log-line/log-line.factor
@@ -35,3 +35,7 @@ M: participant-mode >log-line
M: nick >log-line
[ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
+
+M: topic >log-line
+ [ "* " % dup sender>> % " has set the topic for " % dup channel>> %
+ ": \"" % topic>> % "\"" % ] "" make ;
From 84032835f5b3a1d12f0f749b33b81a38bef62ea3 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 17:11:41 -0300
Subject: [PATCH 02/24] irc.messages: Use GMT times when building a message
---
extra/irc/messages/parser/parser.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor
index 1fa07fc772..ee126b2550 100644
--- a/extra/irc/messages/parser/parser.factor
+++ b/extra/irc/messages/parser/parser.factor
@@ -32,4 +32,4 @@ PRIVATE>
[ >>trailing ]
tri*
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
- now >>timestamp dup sender >>sender ;
+ gmt >>timestamp dup sender >>sender ;
From 01f7f560b0877dfc3756d7cbcfafedc56021a990 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 17:16:24 -0300
Subject: [PATCH 03/24] irc.logbot: Use make to build timestamped string
---
extra/irc/logbot/logbot.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor
index a389304b14..2bf88568f8 100644
--- a/extra/irc/logbot/logbot.factor
+++ b/extra/irc/logbot/logbot.factor
@@ -16,7 +16,7 @@ SYMBOL: current-stream
"irc.freenode.org" 6667 "flogger" f <irc-profile> ;
: add-timestamp ( string timestamp -- string )
- timestamp>hms "[" prepend "] " append prepend ;
+ timestamp>hms [ "[" % % "] " % % ] "" make ;
: timestamp-path ( timestamp -- path )
timestamp>ymd ".log" append log-directory prepend-path ;
From 7f5f8185bf204c151f39c2d70648bf9a9b571d16 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 17:21:31 -0300
Subject: [PATCH 04/24] irc.messages: Set timestamp when constructing, not on
parser
---
extra/irc/client/internals/internals.factor | 2 +-
extra/irc/messages/base/base.factor | 3 ++-
extra/irc/messages/parser/parser.factor | 4 ++--
3 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 5bae054e18..79aaf6bd5a 100644
--- a/extra/irc/client/internals/internals.factor
+++ b/extra/irc/client/internals/internals.factor
@@ -52,7 +52,7 @@ M: to-all-chats message-forwards drop chats> ;
M: to-many-chats message-forwards sender>> participant-chats ;
GENERIC: process-message ( irc-message -- )
-M: object process-message drop ;
+M: object process-message drop ;
M: ping process-message trailing>> /PONG ;
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor
index d67d226d9b..b785970520 100644
--- a/extra/irc/messages/base/base.factor
+++ b/extra/irc/messages/base/base.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.parser classes.tuple
+USING: accessors arrays assocs calendar classes.parser classes.tuple
combinators fry generic.parser kernel lexer
mirrors namespaces parser sequences splitting strings words ;
IN: irc.messages.base
@@ -51,6 +51,7 @@ M: irc-message post-process-irc-message drop ;
GENERIC: fill-irc-message-slots ( irc-message -- )
M: irc-message fill-irc-message-slots
+ gmt >>timestamp
{
[ process-irc-trailing ]
[ process-irc-prefix ]
diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor
index ee126b2550..06a41b0aaa 100644
--- a/extra/irc/messages/parser/parser.factor
+++ b/extra/irc/messages/parser/parser.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry splitting ascii calendar accessors combinators
+USING: kernel fry splitting ascii accessors combinators
arrays classes.tuple math.order words assocs
irc.messages.base sequences ;
IN: irc.messages.parser
@@ -32,4 +32,4 @@ PRIVATE>
[ >>trailing ]
tri*
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
- gmt >>timestamp dup sender >>sender ;
+ dup sender >>sender ;
From 2c46304c75ae76082e25c59ae7cf0b05143ffa5f Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 21:33:21 -0300
Subject: [PATCH 05/24] irc.logbot: Use <file-appender> instead of
<file-writter>
---
extra/irc/logbot/logbot.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor
index 2bf88568f8..ff8085a9a9 100644
--- a/extra/irc/logbot/logbot.factor
+++ b/extra/irc/logbot/logbot.factor
@@ -27,7 +27,7 @@ SYMBOL: current-stream
] [
current-stream get [ dispose ] when*
[ day-of-year current-day set ]
- [ timestamp-path latin1 <file-writer> ] bi
+ [ timestamp-path latin1 <file-appender> ] bi
current-stream set
] if current-stream get ;
From 34ec9af2ad82d18492c3670b9dad2c0fd5cff0db Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 21:35:26 -0300
Subject: [PATCH 06/24] irc.client: More robust reconnection
---
extra/irc/client/chats/chats.factor | 8 ++--
extra/irc/client/internals/internals.factor | 46 ++++++++++++---------
2 files changed, 31 insertions(+), 23 deletions(-)
diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor
index 7910afb22a..3f6cf4945d 100644
--- a/extra/irc/client/chats/chats.factor
+++ b/extra/irc/client/chats/chats.factor
@@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
- chats is-running nick connect reconnect-time is-ready
+ chats is-running nick connect is-ready
+ reconnect-time reconnect-attempts
exceptions ;
: <irc-client> ( profile -- irc-client )
@@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
- 15 seconds >>reconnect-time
+ 30 seconds >>reconnect-time
+ 10 >>reconnect-attempts
V{ } clone >>exceptions
- [ <inet> latin1 <client> ] >>connect ;
+ [ <inet> latin1 <client> drop ] >>connect ;
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 79aaf6bd5a..0a4fe11830 100644
--- a/extra/irc/client/internals/internals.factor
+++ b/extra/irc/client/internals/internals.factor
@@ -3,10 +3,17 @@
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
strings words.symbol irc.messages.base irc.client.participants fry threads
-combinators irc.messages.parser ;
+combinators irc.messages.parser math ;
EXCLUDE: sequences => join ;
IN: irc.client.internals
+: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
+ dup 0 > [
+ [ drop call( host port -- stream ) ]
+ [ drop 15 sleep 1- do-connect ]
+ recover
+ ] [ 2drop 2drop f ] if ;
+
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
@@ -15,18 +22,27 @@ IN: irc.client.internals
"USER " prepend " hostname servername :irc.factor" append irc-print ;
: /CONNECT ( server port -- stream )
- irc> connect>> call( host port -- stream local ) drop ;
+ irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
: /JOIN ( channel password -- )
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+: try-connect ( -- stream/f )
+ irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
+
+: (terminate-irc) ( -- )
+ irc> dup is-running>> [
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
+ ] [ drop ] if ;
+
: (connect-irc) ( -- )
- irc> {
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
- [ (>>stream) ]
- [ t swap (>>is-running) ]
- [ in-messages>> [ irc-connected ] dip mailbox-put ]
- } cleave ;
+ try-connect [
+ [ irc> ] dip >>stream t >>is-running
+ in-messages>> [ irc-connected ] dip mailbox-put
+ ] [ (terminate-irc) ] if* ;
: (do-login) ( -- ) irc> nick>> /LOGIN ;
@@ -92,9 +108,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
: (handle-disconnect) ( -- )
irc-disconnected irc> in-messages>> mailbox-put
- irc> reconnect-time>> sleep
- (connect-irc)
- (do-login) ;
+ (connect-irc) (do-login) ;
: handle-disconnect ( error -- ? )
[ irc> exceptions>> push ] when*
@@ -155,12 +169,4 @@ M: irc-channel-chat remove-chat
[ part new annotate-message irc-send ]
[ name>> unregister-chat ] bi ;
-: (terminate-irc) ( -- )
- irc> dup is-running>> [
- f >>is-running
- [ stream>> dispose ] keep
- [ in-messages>> ] [ out-messages>> ] bi 2array
- [ irc-end swap mailbox-put ] each
- ] [ drop ] if ;
-
-: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
\ No newline at end of file
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
From 460de5bbef80253c2a1bb0a691871fa7b2436212 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 22:19:16 -0300
Subject: [PATCH 07/24] irc.messages: Add predicate classes for ctcp and action
messages
---
extra/irc/messages/messages-tests.factor | 5 ++++-
extra/irc/messages/messages.factor | 16 +++++++++++++---
2 files changed, 17 insertions(+), 4 deletions(-)
diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor
index 539fba54eb..347bdd00fa 100644
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@@ -71,4 +71,7 @@ IN: irc.messages.tests
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
- string>irc-message f >>timestamp ] unit-test
\ No newline at end of file
+ string>irc-message f >>timestamp ] unit-test
+
+{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!"
+ string>irc-message action? ] unit-test
diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index a6bf02f8a7..2006cc24c3 100755
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
-arrays classes.tuple math.order words assocs strings irc.messages.base ;
+arrays classes.tuple math.order words assocs strings irc.messages.base
+combinators.short-circuit math ;
EXCLUDE: sequences => join ;
IN: irc.messages
@@ -61,8 +62,17 @@ IRC: rpl-names-end "366" nickname channel : comment ;
IRC: rpl-nickname-in-use "433" _ name ;
IRC: rpl-nick-collision "436" nickname : comment ;
+PREDICATE: channel-mode < mode name>> first "#&" member? ;
+PREDICATE: participant-mode < channel-mode parameter>> ;
+PREDICATE: ctcp < privmsg
+ trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
+PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
+
M: rpl-names post-process-irc-message ( rpl-names -- )
[ [ blank? ] trim " " split ] change-nicks drop ;
-PREDICATE: channel-mode < mode name>> first "#&" member? ;
-PREDICATE: participant-mode < channel-mode parameter>> ;
+M: ctcp post-process-irc-message ( ctcp -- )
+ [ rest but-last ] change-text drop ;
+
+M: action post-process-irc-message ( action -- )
+ [ 7 tail ] change-text call-next-method ;
From 7503c9876809f72d98d97dc94d63138d74cf5703 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 22:19:45 -0300
Subject: [PATCH 08/24] irc.logbot: Format for actions
---
extra/irc/logbot/log-line/log-line.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor
index 255c46e5f3..0960a3cedb 100644
--- a/extra/irc/logbot/log-line/log-line.factor
+++ b/extra/irc/logbot/log-line/log-line.factor
@@ -11,6 +11,12 @@ GENERIC: >log-line ( object -- line )
M: irc-message >log-line line>> ;
+M: ctcp >log-line
+ [ "CTCP: " % dup sender>> % " " % text>> % ] "" make ;
+
+M: action >log-line
+ [ "* " % dup sender>> % " " % text>> % ] "" make ;
+
M: privmsg >log-line
[ "<" % dup sender>> % "> " % text>> % ] "" make ;
From 17cbf3dded0dccfea50f3031b54b47b9729ee2ce Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 16 Apr 2009 22:28:40 -0300
Subject: [PATCH 09/24] irc.client: Update test
---
extra/irc/client/internals/internals-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor
index d20ae50bcc..8d48f0c0a1 100644
--- a/extra/irc/client/internals/internals-tests.factor
+++ b/extra/irc/client/internals/internals-tests.factor
@@ -76,7 +76,7 @@ M: mb-writer dispose drop ;
! Test connect
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
- [ 2drop <test-stream> t ] >>connect
+ [ 2drop <test-stream> ] >>connect
[
(connect-irc)
(do-login)
From d45d63715b0eb653bc76ca87b99c8de64d482d51 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Mon, 11 May 2009 00:08:34 -0300
Subject: [PATCH 10/24] extra.redis.assoc: Assoc protocol implementation for
Redis
---
extra/redis/assoc/assoc.factor | 41 ++++++++++++++++++++++++++++++++++
extra/redis/assoc/authors.txt | 1 +
extra/redis/assoc/summary.txt | 1 +
3 files changed, 43 insertions(+)
create mode 100644 extra/redis/assoc/assoc.factor
create mode 100644 extra/redis/assoc/authors.txt
create mode 100644 extra/redis/assoc/summary.txt
diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor
new file mode 100644
index 0000000000..2ddf746344
--- /dev/null
+++ b/extra/redis/assoc/assoc.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs io.encodings.8-bit io.sockets
+io.streams.duplex kernel redis sequences ;
+IN: redis.assoc
+
+TUPLE: redis-assoc host port encoding password ;
+
+CONSTANT: default-redis-port 6379
+
+: <redis-assoc> ( -- redis-assoc )
+ redis-assoc new
+ "127.0.0.1" >>host
+ default-redis-port >>port
+ latin1 >>encoding ;
+
+INSTANCE: redis-assoc assoc
+
+: with-redis-assoc ( redis-assoc quot -- )
+ [
+ [ host>> ] [ port>> ] [ encoding>> ] tri
+ [ <inet> ] dip <client> drop
+ ] dip with-stream ; inline
+
+M: redis-assoc at* [ redis-get dup >boolean ] with-redis-assoc ;
+
+M: redis-assoc assoc-size [ redis-dbsize ] with-redis-assoc ;
+
+M: redis-assoc >alist
+ [ "*" redis-keys dup redis-mget zip ] with-redis-assoc ;
+
+M: redis-assoc set-at [ redis-set drop ] with-redis-assoc ;
+
+M: redis-assoc delete-at [ redis-del drop ] with-redis-assoc ;
+
+M: redis-assoc clear-assoc
+ [ "*" redis-keys [ redis-del drop ] each ] with-redis-assoc ;
+
+M: redis-assoc equal? assoc= ;
+
+M: redis-assoc hashcode* assoc-hashcode ;
diff --git a/extra/redis/assoc/authors.txt b/extra/redis/assoc/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/redis/assoc/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/redis/assoc/summary.txt b/extra/redis/assoc/summary.txt
new file mode 100644
index 0000000000..72a76ab9f0
--- /dev/null
+++ b/extra/redis/assoc/summary.txt
@@ -0,0 +1 @@
+Assoc protocol implementation for Redis
From 462b66a696368d0121ec4e808a8ee3f2b96f9d2e Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Mon, 11 May 2009 00:09:32 -0300
Subject: [PATCH 11/24] extra.redis: Make redis-keys return an array of keys
instead of a space separated string of keys
---
extra/redis/redis.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor
index 1f6d732407..a5e7d74d46 100644
--- a/extra/redis/redis.factor
+++ b/extra/redis/redis.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: io redis.response-parser redis.command-writer ;
+USING: io redis.response-parser redis.command-writer splitting ;
IN: redis
#! Connection
@@ -23,7 +23,7 @@ IN: redis
: redis-type ( key -- response ) type flush read-response ;
#! Key space
-: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-keys ( pattern -- response ) keys flush read-response " " split ;
: redis-randomkey ( -- response ) randomkey flush read-response ;
: redis-rename ( newkey key -- response ) rename flush read-response ;
: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
From 7edcc651593967de799df3d711d5f603474e25ec Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Mon, 11 May 2009 00:44:09 -0300
Subject: [PATCH 12/24] extra.redis: Replace 'redis-assoc' with the more
general 'redis' type (now in the redis vocab), add support for automatic
authentification when calling 'with-redis'
---
extra/redis/assoc/assoc.factor | 39 +++++++++-------------------------
extra/redis/redis.factor | 25 +++++++++++++++++++++-
2 files changed, 34 insertions(+), 30 deletions(-)
diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor
index 2ddf746344..2830e93b25 100644
--- a/extra/redis/assoc/assoc.factor
+++ b/extra/redis/assoc/assoc.factor
@@ -1,41 +1,22 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs io.encodings.8-bit io.sockets
-io.streams.duplex kernel redis sequences ;
+USING: assocs kernel redis sequences ;
IN: redis.assoc
-TUPLE: redis-assoc host port encoding password ;
+INSTANCE: redis assoc
-CONSTANT: default-redis-port 6379
+M: redis at* [ redis-get dup >boolean ] with-redis ;
-: <redis-assoc> ( -- redis-assoc )
- redis-assoc new
- "127.0.0.1" >>host
- default-redis-port >>port
- latin1 >>encoding ;
+M: redis assoc-size [ redis-dbsize ] with-redis ;
-INSTANCE: redis-assoc assoc
+M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
-: with-redis-assoc ( redis-assoc quot -- )
- [
- [ host>> ] [ port>> ] [ encoding>> ] tri
- [ <inet> ] dip <client> drop
- ] dip with-stream ; inline
+M: redis set-at [ redis-set drop ] with-redis ;
-M: redis-assoc at* [ redis-get dup >boolean ] with-redis-assoc ;
+M: redis delete-at [ redis-del drop ] with-redis ;
-M: redis-assoc assoc-size [ redis-dbsize ] with-redis-assoc ;
+M: redis clear-assoc [ "*" redis-keys [ redis-del drop ] each ] with-redis ;
-M: redis-assoc >alist
- [ "*" redis-keys dup redis-mget zip ] with-redis-assoc ;
+M: redis equal? assoc= ;
-M: redis-assoc set-at [ redis-set drop ] with-redis-assoc ;
-
-M: redis-assoc delete-at [ redis-del drop ] with-redis-assoc ;
-
-M: redis-assoc clear-assoc
- [ "*" redis-keys [ redis-del drop ] each ] with-redis-assoc ;
-
-M: redis-assoc equal? assoc= ;
-
-M: redis-assoc hashcode* assoc-hashcode ;
+M: redis hashcode* assoc-hashcode ;
diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor
index a5e7d74d46..466fdc9937 100644
--- a/extra/redis/redis.factor
+++ b/extra/redis/redis.factor
@@ -1,6 +1,8 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: io redis.response-parser redis.command-writer splitting ;
+USING: accessors io io.encodings.8-bit io.sockets
+io.streams.duplex kernel redis.command-writer
+redis.response-parser splitting ;
IN: redis
#! Connection
@@ -72,3 +74,24 @@ IN: redis
#! Remote server control
: redis-info ( -- response ) info flush read-response ;
: redis-monitor ( -- response ) monitor flush read-response ;
+
+#! Redis object
+TUPLE: redis host port encoding password ;
+
+CONSTANT: default-redis-port 6379
+
+: <redis> ( -- redis )
+ redis new
+ "127.0.0.1" >>host
+ default-redis-port >>port
+ latin1 >>encoding ;
+
+: redis-do-connect ( redis -- stream )
+ [ host>> ] [ port>> ] [ encoding>> ] tri
+ [ <inet> ] dip <client> drop ;
+
+: with-redis ( redis quot -- )
+ [
+ [ redis-do-connect ] [ password>> ] bi
+ [ swap [ [ redis-auth drop ] with-stream* ] keep ] when*
+ ] dip with-stream ; inline
From cb76bddd8fb523d90d447d95b2fd9bf82c974c69 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Mon, 11 May 2009 00:50:22 -0300
Subject: [PATCH 13/24] redis.assoc: Use redis-flushdb in clear-assoc
---
extra/redis/assoc/assoc.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor
index 2830e93b25..e8bdbbb935 100644
--- a/extra/redis/assoc/assoc.factor
+++ b/extra/redis/assoc/assoc.factor
@@ -15,7 +15,7 @@ M: redis set-at [ redis-set drop ] with-redis ;
M: redis delete-at [ redis-del drop ] with-redis ;
-M: redis clear-assoc [ "*" redis-keys [ redis-del drop ] each ] with-redis ;
+M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
M: redis equal? assoc= ;
From c026702390495bfa127c4a962367642ede87dbb3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 12 May 2009 18:04:22 -0500
Subject: [PATCH 14/24] fix stat on 64bit linux
---
basis/unix/stat/linux/64/64.factor | 36 ++++++++++++++++--------------
1 file changed, 19 insertions(+), 17 deletions(-)
diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor
index 98c4b90f32..581525dda0 100644
--- a/basis/unix/stat/linux/64/64.factor
+++ b/basis/unix/stat/linux/64/64.factor
@@ -2,24 +2,26 @@ USING: kernel alien.syntax math sequences unix
alien.c-types arrays accessors combinators ;
IN: unix.stat
-! stat64
+! Ubuntu 7.10 64-bit
+
C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ushort" "__pad1" }
- { "__ino_t" "__st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { { "ushort" 2 } "__pad2" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "ulonglong" "st_ino" } ;
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "nlink_t" "st_nlink" }
+ { "mode_t" "st_mode" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "int" "pad0" }
+ { "dev_t" "st_rdev" }
+ { "off64_t" "st_size" }
+ { "blksize_t" "st_blksize" }
+ { "blkcnt64_t" "st_blocks" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "long" "__unused0" }
+ { "long" "__unused1" }
+ { "long" "__unused2" } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
From fd3a56819156f74900d569bee39f3b212811750b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 May 2009 20:47:20 -0500
Subject: [PATCH 15/24] Fix GENERIC# with out of bounds dispatch position
---
core/generic/single/single-tests.factor | 7 ++++++-
core/generic/standard/standard.factor | 6 +++++-
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor
index e48d404b92..61ae4e1ba1 100644
--- a/core/generic/single/single-tests.factor
+++ b/core/generic/single/single-tests.factor
@@ -274,4 +274,9 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
-[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
\ No newline at end of file
+[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
+
+! Corner case
+[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
+[ error>> bad-dispatch-position? ]
+must-fail-with
\ No newline at end of file
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index b76bcaa582..0d1220beac 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -6,9 +6,13 @@ generic.single.private quotations kernel.private
assocs arrays layouts make ;
IN: generic.standard
+ERROR: bad-dispatch-position # ;
+
TUPLE: standard-combination < single-combination # ;
-C: <standard-combination> standard-combination
+: <standard-combination> ( # -- standard-combination )
+ dup 0 < [ bad-dispatch-position ] when
+ standard-combination boa ;
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
From b67b617746c8399ff279661900d03b8b2b9d315a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 May 2009 21:23:52 -0500
Subject: [PATCH 16/24] Fix compiler breakage if a GENERIC# has an incorrect
stack effect declaration
---
basis/compiler/tests/optimizer.factor | 18 +++++++++++++++++-
.../tree/propagation/inlining/inlining.factor | 8 +++++---
2 files changed, 22 insertions(+), 4 deletions(-)
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index fa1248435b..72618db456 100644
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -395,4 +395,20 @@ DEFER: loop-bbb
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
-[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
\ No newline at end of file
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
+
+! Optimizer needs to ignore invalid generics
+GENERIC# bad-dispatch-position-test* 3 ( -- )
+
+M: object bad-dispatch-position-test* ;
+
+: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
+
+[ 1 2 3 4 bad-dispatch-position-test ] must-fail
+
+[ ] [
+ [
+ \ bad-dispatch-position-test forget
+ \ bad-dispatch-position-test* forget
+ ] with-compilation-unit
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index ee9abf00ec..6be3bed8d3 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
- [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
- [ swap nth value-info class>> dup ] dip
- specific-method
+ 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
+ [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
+ [ swap nth value-info class>> dup ] dip
+ specific-method
+ ] if
] if ;
: inline-standard-method ( #call word -- ? )
From 69cb3dee5ed1a59d7f6029568031168dd1f6f01b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 13 May 2009 00:58:54 -0500
Subject: [PATCH 17/24] Fix FEP if there are too many words in the image, clean
up some VM code
---
core/memory/memory-tests.factor | 14 ++------
vm/arrays.hpp | 2 +-
vm/byte_arrays.hpp | 3 +-
vm/callstack.cpp | 57 +++++++++++++--------------------
vm/callstack.hpp | 20 +++++++++---
vm/code_heap.cpp | 6 ++--
vm/data_heap.cpp | 45 +++++++++++++++++++-------
vm/data_heap.hpp | 1 +
vm/debug.cpp | 6 ++--
vm/tagged.hpp | 0
10 files changed, 81 insertions(+), 73 deletions(-)
mode change 100644 => 100755 core/memory/memory-tests.factor
mode change 100644 => 100755 vm/arrays.hpp
mode change 100644 => 100755 vm/byte_arrays.hpp
mode change 100644 => 100755 vm/data_heap.hpp
mode change 100644 => 100755 vm/tagged.hpp
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
old mode 100644
new mode 100755
index a6ecdc005e..8ecf673b8a
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -27,16 +27,8 @@ TUPLE: testing x y z ;
[ save-image-and-exit ] must-fail
-[ ] [
- num-types get [
- type>class [
- dup . flush
- "predicate" word-prop instances [
- class drop
- ] each
- ] when*
- ] each
-] unit-test
-
! Erg's bug
2 [ [ [ 3 throw ] instances ] must-fail ] times
+
+! Bug found on Windows build box, having too many words in the image breaks 'become'
+[ ] [ 100000 [ f f <word> ] replicate { } { } become drop ] unit-test
diff --git a/vm/arrays.hpp b/vm/arrays.hpp
old mode 100644
new mode 100755
index 82da3bb71d..06e6ed6e4d
--- a/vm/arrays.hpp
+++ b/vm/arrays.hpp
@@ -34,7 +34,7 @@ struct growable_array {
cell count;
gc_root<array> elements;
- growable_array() : count(0), elements(allot_array(2,F)) {}
+ growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {}
void add(cell elt);
void trim();
diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp
old mode 100644
new mode 100755
index ebdc6bead6..6de8ee4e9f
--- a/vm/byte_arrays.hpp
+++ b/vm/byte_arrays.hpp
@@ -7,12 +7,11 @@ PRIMITIVE(byte_array);
PRIMITIVE(uninitialized_byte_array);
PRIMITIVE(resize_byte_array);
-/* Macros to simulate a byte vector in C */
struct growable_byte_array {
cell count;
gc_root<byte_array> elements;
- growable_byte_array() : count(0), elements(allot_byte_array(2)) { }
+ growable_byte_array(cell capacity = 40) : count(0), elements(allot_byte_array(capacity)) { }
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);
diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index e7009183e9..4ef6db10bd 100755
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -11,22 +11,6 @@ static void check_frame(stack_frame *frame)
#endif
}
-void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
-{
- stack_frame *frame = (stack_frame *)bottom - 1;
-
- while((cell)frame >= top)
- {
- iterator(frame);
- frame = frame_successor(frame);
- }
-}
-
-void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
-{
- iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
-}
-
callstack *allot_callstack(cell size)
{
callstack *stack = allot<callstack>(callstack_size(size));
@@ -138,36 +122,39 @@ cell frame_scan(stack_frame *frame)
return F;
}
-/* C doesn't have closures... */
-static cell frame_count;
-
-void count_stack_frame(stack_frame *frame)
+namespace
{
- frame_count += 2;
-}
-static cell frame_index;
-static array *frames;
+struct stack_frame_counter {
+ cell count;
+ stack_frame_counter() : count(0) {}
+ void operator()(stack_frame *frame) { count += 2; }
+};
+
+struct stack_frame_accumulator {
+ cell index;
+ array *frames;
+ stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal<array>(count)) {}
+ void operator()(stack_frame *frame)
+ {
+ set_array_nth(frames,index++,frame_executing(frame));
+ set_array_nth(frames,index++,frame_scan(frame));
+ }
+};
-void stack_frame_to_array(stack_frame *frame)
-{
- set_array_nth(frames,frame_index++,frame_executing(frame));
- set_array_nth(frames,frame_index++,frame_scan(frame));
}
PRIMITIVE(callstack_to_array)
{
gc_root<callstack> callstack(dpop());
- frame_count = 0;
- iterate_callstack_object(callstack.untagged(),count_stack_frame);
+ stack_frame_counter counter;
+ iterate_callstack_object(callstack.untagged(),counter);
- frames = allot_array_internal<array>(frame_count);
+ stack_frame_accumulator accum(counter.count);
+ iterate_callstack_object(callstack.untagged(),accum);
- frame_index = 0;
- iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
-
- dpush(tag<array>(frames));
+ dpush(tag<array>(accum.frames));
}
stack_frame *innermost_stack_frame(callstack *stack)
diff --git a/vm/callstack.hpp b/vm/callstack.hpp
index a128cfee47..d92e5f69e0 100755
--- a/vm/callstack.hpp
+++ b/vm/callstack.hpp
@@ -6,11 +6,7 @@ inline static cell callstack_size(cell size)
return sizeof(callstack) + size;
}
-typedef void (*CALLSTACK_ITER)(stack_frame *frame);
-
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
-void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator);
-void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator);
stack_frame *frame_successor(stack_frame *frame);
code_block *frame_code(stack_frame *frame);
cell frame_executing(stack_frame *frame);
@@ -26,4 +22,20 @@ PRIMITIVE(set_innermost_stack_frame_quot);
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
+template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame);
+ frame = frame_successor(frame);
+ }
+}
+
+template<typename T> void iterate_callstack_object(callstack *stack, T &iterator)
+{
+ iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
+}
+
}
diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp
index 2260d133fc..2d2e975fb4 100755
--- a/vm/code_heap.cpp
+++ b/vm/code_heap.cpp
@@ -173,8 +173,7 @@ void forward_object_xts()
}
}
- /* End the heap scan */
- gc_off = false;
+ end_scan();
}
/* Set the XT fields now that the heap has been compacted */
@@ -203,8 +202,7 @@ void fixup_object_xts()
}
}
- /* End the heap scan */
- gc_off = false;
+ end_scan();
}
/* Move all free space to the end of the code heap. This is not very efficient,
diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp
index d921d373da..5b20ec890f 100755
--- a/vm/data_heap.cpp
+++ b/vm/data_heap.cpp
@@ -318,6 +318,11 @@ void begin_scan()
gc_off = true;
}
+void end_scan()
+{
+ gc_off = false;
+}
+
PRIMITIVE(begin_scan)
{
begin_scan();
@@ -348,24 +353,40 @@ PRIMITIVE(end_scan)
gc_off = false;
}
-cell find_all_words()
+template<typename T> void each_object(T &functor)
{
- growable_array words;
-
begin_scan();
-
cell obj;
while((obj = next_object()) != F)
- {
- if(tagged<object>(obj).type_p(WORD_TYPE))
- words.add(obj);
- }
+ functor(tagged<object>(obj));
+ end_scan();
+}
- /* End heap scan */
- gc_off = false;
+namespace
+{
- words.trim();
- return words.elements.value();
+struct word_counter {
+ cell count;
+ word_counter() : count(0) {}
+ void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) count++; }
+};
+
+struct word_accumulator {
+ growable_array words;
+ word_accumulator(int count) : words(count) {}
+ void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
+};
+
+}
+
+cell find_all_words()
+{
+ word_counter counter;
+ each_object(counter);
+ word_accumulator accum(counter.count);
+ each_object(accum);
+ accum.words.trim();
+ return accum.words.elements.value();
}
}
diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp
old mode 100644
new mode 100755
index 567c8f9944..4ef72a6fcb
--- a/vm/data_heap.hpp
+++ b/vm/data_heap.hpp
@@ -89,6 +89,7 @@ cell binary_payload_start(object *pointer);
cell object_size(cell tagged);
void begin_scan();
+void end_scan();
cell next_object();
PRIMITIVE(data_room);
diff --git a/vm/debug.cpp b/vm/debug.cpp
index 49fdd92541..22e92809a7 100755
--- a/vm/debug.cpp
+++ b/vm/debug.cpp
@@ -253,8 +253,7 @@ void dump_objects(cell type)
}
}
- /* end scan */
- gc_off = false;
+ end_scan();
}
cell look_for;
@@ -280,8 +279,7 @@ void find_data_references(cell look_for_)
while((obj = next_object()) != F)
do_slots(UNTAG(obj),find_data_references_step);
- /* end scan */
- gc_off = false;
+ end_scan();
}
/* Dump all code blocks for debugging */
diff --git a/vm/tagged.hpp b/vm/tagged.hpp
old mode 100644
new mode 100755
From 9ef162e2ef943bf6b050a339a1461270336e14dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 13 May 2009 01:08:16 -0500
Subject: [PATCH 18/24] More VM cleanups
---
vm/layouts.hpp | 2 +-
vm/master.hpp | 2 --
vm/os-unix.hpp | 10 ++++++----
vm/os-windows.hpp | 12 ++++++------
vm/utilities.cpp | 8 ++++----
5 files changed, 17 insertions(+), 17 deletions(-)
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index f8672e4522..3fe89cb558 100755
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -90,7 +90,7 @@ inline static cell tag_for(cell type)
return type < HEADER_TYPE ? type : OBJECT_TYPE;
}
-class object;
+struct object;
struct header {
cell value;
diff --git a/vm/master.hpp b/vm/master.hpp
index 6164c9ea30..83f0920f5b 100755
--- a/vm/master.hpp
+++ b/vm/master.hpp
@@ -19,8 +19,6 @@
#include <stdlib.h>
#include <string.h>
#include <time.h>
-#include <unistd.h>
-#include <sys/param.h>
/* C++ headers */
#if __GNUC__ == 4
diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp
index 07ec385763..8aff18364e 100755
--- a/vm/os-unix.hpp
+++ b/vm/os-unix.hpp
@@ -1,3 +1,5 @@
+#include <unistd.h>
+#include <sys/param.h>
#include <dirent.h>
#include <sys/mman.h>
#include <sys/types.h>
@@ -24,13 +26,13 @@ typedef char symbol_char;
#define FSEEK fseeko
#define FIXNUM_FORMAT "%ld"
-#define cell_FORMAT "%lu"
-#define cell_HEX_FORMAT "%lx"
+#define CELL_FORMAT "%lu"
+#define CELL_HEX_FORMAT "%lx"
#ifdef FACTOR_64
- #define cell_HEX_PAD_FORMAT "%016lx"
+ #define CELL_HEX_PAD_FORMAT "%016lx"
#else
- #define cell_HEX_PAD_FORMAT "%08lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
#endif
#define FIXNUM_FORMAT "%ld"
diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp
index 5422216593..27e2775289 100755
--- a/vm/os-windows.hpp
+++ b/vm/os-windows.hpp
@@ -22,14 +22,14 @@ typedef wchar_t vm_char;
#define FSEEK fseek
#ifdef WIN64
- #define cell_FORMAT "%Iu"
- #define cell_HEX_FORMAT "%Ix"
- #define cell_HEX_PAD_FORMAT "%016Ix"
+ #define CELL_FORMAT "%Iu"
+ #define CELL_HEX_FORMAT "%Ix"
+ #define CELL_HEX_PAD_FORMAT "%016Ix"
#define FIXNUM_FORMAT "%Id"
#else
- #define cell_FORMAT "%lu"
- #define cell_HEX_FORMAT "%lx"
- #define cell_HEX_PAD_FORMAT "%08lx"
+ #define CELL_FORMAT "%lu"
+ #define CELL_HEX_FORMAT "%lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
#define FIXNUM_FORMAT "%ld"
#endif
diff --git a/vm/utilities.cpp b/vm/utilities.cpp
index df5c09847d..37fe28948e 100755
--- a/vm/utilities.cpp
+++ b/vm/utilities.cpp
@@ -32,17 +32,17 @@ void print_string(const char *str)
void print_cell(cell x)
{
- printf(cell_FORMAT,x);
+ printf(CELL_FORMAT,x);
}
void print_cell_hex(cell x)
{
- printf(cell_HEX_FORMAT,x);
+ printf(CELL_HEX_FORMAT,x);
}
void print_cell_hex_pad(cell x)
{
- printf(cell_HEX_PAD_FORMAT,x);
+ printf(CELL_HEX_PAD_FORMAT,x);
}
void print_fixnum(fixnum x)
@@ -53,7 +53,7 @@ void print_fixnum(fixnum x)
cell read_cell_hex()
{
cell cell;
- if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
+ if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
};
From 1e6227fe68edaa2acc6f05f38b64e5ba7a0a83d4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 May 2009 03:49:51 -0500
Subject: [PATCH 19/24] os-linux.cpp: inotify wrappers should be VM_C_API
---
vm/os-linux.cpp | 12 ++++++------
vm/os-linux.hpp | 6 +++---
2 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp
index f5814d7f18..2bc121ffc7 100644
--- a/vm/os-linux.cpp
+++ b/vm/os-linux.cpp
@@ -23,36 +23,36 @@ const char *vm_executable_path()
#ifdef SYS_inotify_init
-int inotify_init()
+VM_C_API int inotify_init()
{
return syscall(SYS_inotify_init);
}
-int inotify_add_watch(int fd, const char *name, u32 mask)
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
return syscall(SYS_inotify_add_watch, fd, name, mask);
}
-int inotify_rm_watch(int fd, u32 wd)
+VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
return syscall(SYS_inotify_rm_watch, fd, wd);
}
#else
-int inotify_init()
+VM_C_API int inotify_init()
{
not_implemented_error();
return -1;
}
-int inotify_add_watch(int fd, const char *name, u32 mask)
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
not_implemented_error();
return -1;
}
-int inotify_rm_watch(int fd, u32 wd)
+VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
not_implemented_error();
return -1;
diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp
index 257a6b0692..de13896b9a 100644
--- a/vm/os-linux.hpp
+++ b/vm/os-linux.hpp
@@ -3,8 +3,8 @@
namespace factor
{
-int inotify_init();
-int inotify_add_watch(int fd, const char *name, u32 mask);
-int inotify_rm_watch(int fd, u32 wd);
+VM_C_API int inotify_init();
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask);
+VM_C_API int inotify_rm_watch(int fd, u32 wd);
}
From 2b9631075a4d7bf69ce7dde82c8379f221944c77 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 May 2009 14:18:10 -0500
Subject: [PATCH 20/24] Graduation! Move game-input and iokit into basis
---
{extra => basis}/game-input/authors.txt | 0
{extra => basis}/game-input/dinput/authors.txt | 0
{extra => basis}/game-input/dinput/dinput.factor | 0
{extra => basis}/game-input/dinput/keys-array/keys-array.factor | 0
{extra => basis}/game-input/dinput/summary.txt | 0
{extra => basis}/game-input/dinput/tags.txt | 0
{extra => basis}/game-input/game-input-docs.factor | 0
{extra => basis}/game-input/game-input-tests.factor | 0
{extra => basis}/game-input/game-input.factor | 0
{extra => basis}/game-input/iokit/authors.txt | 0
{extra => basis}/game-input/iokit/iokit.factor | 0
{extra => basis}/game-input/iokit/summary.txt | 0
{extra => basis}/game-input/iokit/tags.txt | 0
{extra => basis}/game-input/scancodes/authors.txt | 0
{extra => basis}/game-input/scancodes/scancodes.factor | 0
{extra => basis}/game-input/scancodes/summary.txt | 0
{extra => basis}/game-input/scancodes/tags.txt | 0
{extra => basis}/game-input/summary.txt | 0
{extra => basis}/game-input/tags.txt | 0
{extra => basis}/iokit/authors.txt | 0
{extra => basis}/iokit/hid/authors.txt | 0
{extra => basis}/iokit/hid/hid.factor | 0
{extra => basis}/iokit/hid/summary.txt | 0
{extra => basis}/iokit/hid/tags.txt | 0
{extra => basis}/iokit/iokit.factor | 0
{extra => basis}/iokit/summary.txt | 0
{extra => basis}/iokit/tags.txt | 0
27 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => basis}/game-input/authors.txt (100%)
rename {extra => basis}/game-input/dinput/authors.txt (100%)
rename {extra => basis}/game-input/dinput/dinput.factor (100%)
rename {extra => basis}/game-input/dinput/keys-array/keys-array.factor (100%)
rename {extra => basis}/game-input/dinput/summary.txt (100%)
rename {extra => basis}/game-input/dinput/tags.txt (100%)
rename {extra => basis}/game-input/game-input-docs.factor (100%)
rename {extra => basis}/game-input/game-input-tests.factor (100%)
rename {extra => basis}/game-input/game-input.factor (100%)
rename {extra => basis}/game-input/iokit/authors.txt (100%)
rename {extra => basis}/game-input/iokit/iokit.factor (100%)
rename {extra => basis}/game-input/iokit/summary.txt (100%)
rename {extra => basis}/game-input/iokit/tags.txt (100%)
rename {extra => basis}/game-input/scancodes/authors.txt (100%)
rename {extra => basis}/game-input/scancodes/scancodes.factor (100%)
rename {extra => basis}/game-input/scancodes/summary.txt (100%)
rename {extra => basis}/game-input/scancodes/tags.txt (100%)
rename {extra => basis}/game-input/summary.txt (100%)
rename {extra => basis}/game-input/tags.txt (100%)
rename {extra => basis}/iokit/authors.txt (100%)
rename {extra => basis}/iokit/hid/authors.txt (100%)
rename {extra => basis}/iokit/hid/hid.factor (100%)
rename {extra => basis}/iokit/hid/summary.txt (100%)
rename {extra => basis}/iokit/hid/tags.txt (100%)
rename {extra => basis}/iokit/iokit.factor (100%)
rename {extra => basis}/iokit/summary.txt (100%)
rename {extra => basis}/iokit/tags.txt (100%)
diff --git a/extra/game-input/authors.txt b/basis/game-input/authors.txt
similarity index 100%
rename from extra/game-input/authors.txt
rename to basis/game-input/authors.txt
diff --git a/extra/game-input/dinput/authors.txt b/basis/game-input/dinput/authors.txt
similarity index 100%
rename from extra/game-input/dinput/authors.txt
rename to basis/game-input/dinput/authors.txt
diff --git a/extra/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
similarity index 100%
rename from extra/game-input/dinput/dinput.factor
rename to basis/game-input/dinput/dinput.factor
diff --git a/extra/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor
similarity index 100%
rename from extra/game-input/dinput/keys-array/keys-array.factor
rename to basis/game-input/dinput/keys-array/keys-array.factor
diff --git a/extra/game-input/dinput/summary.txt b/basis/game-input/dinput/summary.txt
similarity index 100%
rename from extra/game-input/dinput/summary.txt
rename to basis/game-input/dinput/summary.txt
diff --git a/extra/game-input/dinput/tags.txt b/basis/game-input/dinput/tags.txt
similarity index 100%
rename from extra/game-input/dinput/tags.txt
rename to basis/game-input/dinput/tags.txt
diff --git a/extra/game-input/game-input-docs.factor b/basis/game-input/game-input-docs.factor
similarity index 100%
rename from extra/game-input/game-input-docs.factor
rename to basis/game-input/game-input-docs.factor
diff --git a/extra/game-input/game-input-tests.factor b/basis/game-input/game-input-tests.factor
similarity index 100%
rename from extra/game-input/game-input-tests.factor
rename to basis/game-input/game-input-tests.factor
diff --git a/extra/game-input/game-input.factor b/basis/game-input/game-input.factor
similarity index 100%
rename from extra/game-input/game-input.factor
rename to basis/game-input/game-input.factor
diff --git a/extra/game-input/iokit/authors.txt b/basis/game-input/iokit/authors.txt
similarity index 100%
rename from extra/game-input/iokit/authors.txt
rename to basis/game-input/iokit/authors.txt
diff --git a/extra/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor
similarity index 100%
rename from extra/game-input/iokit/iokit.factor
rename to basis/game-input/iokit/iokit.factor
diff --git a/extra/game-input/iokit/summary.txt b/basis/game-input/iokit/summary.txt
similarity index 100%
rename from extra/game-input/iokit/summary.txt
rename to basis/game-input/iokit/summary.txt
diff --git a/extra/game-input/iokit/tags.txt b/basis/game-input/iokit/tags.txt
similarity index 100%
rename from extra/game-input/iokit/tags.txt
rename to basis/game-input/iokit/tags.txt
diff --git a/extra/game-input/scancodes/authors.txt b/basis/game-input/scancodes/authors.txt
similarity index 100%
rename from extra/game-input/scancodes/authors.txt
rename to basis/game-input/scancodes/authors.txt
diff --git a/extra/game-input/scancodes/scancodes.factor b/basis/game-input/scancodes/scancodes.factor
similarity index 100%
rename from extra/game-input/scancodes/scancodes.factor
rename to basis/game-input/scancodes/scancodes.factor
diff --git a/extra/game-input/scancodes/summary.txt b/basis/game-input/scancodes/summary.txt
similarity index 100%
rename from extra/game-input/scancodes/summary.txt
rename to basis/game-input/scancodes/summary.txt
diff --git a/extra/game-input/scancodes/tags.txt b/basis/game-input/scancodes/tags.txt
similarity index 100%
rename from extra/game-input/scancodes/tags.txt
rename to basis/game-input/scancodes/tags.txt
diff --git a/extra/game-input/summary.txt b/basis/game-input/summary.txt
similarity index 100%
rename from extra/game-input/summary.txt
rename to basis/game-input/summary.txt
diff --git a/extra/game-input/tags.txt b/basis/game-input/tags.txt
similarity index 100%
rename from extra/game-input/tags.txt
rename to basis/game-input/tags.txt
diff --git a/extra/iokit/authors.txt b/basis/iokit/authors.txt
similarity index 100%
rename from extra/iokit/authors.txt
rename to basis/iokit/authors.txt
diff --git a/extra/iokit/hid/authors.txt b/basis/iokit/hid/authors.txt
similarity index 100%
rename from extra/iokit/hid/authors.txt
rename to basis/iokit/hid/authors.txt
diff --git a/extra/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor
similarity index 100%
rename from extra/iokit/hid/hid.factor
rename to basis/iokit/hid/hid.factor
diff --git a/extra/iokit/hid/summary.txt b/basis/iokit/hid/summary.txt
similarity index 100%
rename from extra/iokit/hid/summary.txt
rename to basis/iokit/hid/summary.txt
diff --git a/extra/iokit/hid/tags.txt b/basis/iokit/hid/tags.txt
similarity index 100%
rename from extra/iokit/hid/tags.txt
rename to basis/iokit/hid/tags.txt
diff --git a/extra/iokit/iokit.factor b/basis/iokit/iokit.factor
similarity index 100%
rename from extra/iokit/iokit.factor
rename to basis/iokit/iokit.factor
diff --git a/extra/iokit/summary.txt b/basis/iokit/summary.txt
similarity index 100%
rename from extra/iokit/summary.txt
rename to basis/iokit/summary.txt
diff --git a/extra/iokit/tags.txt b/basis/iokit/tags.txt
similarity index 100%
rename from extra/iokit/tags.txt
rename to basis/iokit/tags.txt
From f43667640a52d4f528752ac864b6af1cc232be0c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Wed, 13 May 2009 16:58:01 -0500
Subject: [PATCH 21/24] Fix regression with: bad interaction between predicate
classes and tuple inheritance, reported by Bruno Deferrari
---
core/classes/predicate/predicate-tests.factor | 19 +++++++++--
core/generic/single/single.factor | 32 ++++++++++++++-----
2 files changed, 40 insertions(+), 11 deletions(-)
diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index a947b9ddc0..80613f4f2e 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -1,5 +1,6 @@
-USING: math tools.test classes.algebra words kernel sequences assocs ;
-IN: classes.predicate
+USING: math tools.test classes.algebra words kernel sequences assocs
+accessors eval definitions compiler.units generic ;
+IN: classes.predicate.tests
PREDICATE: negative < integer 0 < ;
PREDICATE: positive < integer 0 > ;
@@ -18,4 +19,16 @@ M: positive abs ;
[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
-[ 0 ] [ 0 abs ] unit-test
\ No newline at end of file
+[ 0 ] [ 0 abs ] unit-test
+
+! Bug report from Bruno Deferrari
+TUPLE: tuple-a slot ;
+TUPLE: tuple-b < tuple-a ;
+
+PREDICATE: tuple-c < tuple-b slot>> ;
+
+GENERIC: ptest ( tuple -- )
+M: tuple-a ptest drop ;
+IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
+
+[ ] [ tuple-b new ptest ] unit-test
diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor
index 8d84b21bf7..747963256d 100644
--- a/core/generic/single/single.factor
+++ b/core/generic/single/single.factor
@@ -58,13 +58,13 @@ M: single-combination make-default-method
] unless ;
! 1. Flatten methods
-TUPLE: predicate-engine methods ;
+TUPLE: predicate-engine class methods ;
-: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+C: <predicate-engine> predicate-engine
: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-engine> ] unless*
+ dupd [
+ [ ] [ H{ } clone <predicate-engine> ] ?if
[ methods>> set-at ] keep
] change-at ;
@@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
[ <enum> swap update ] keep
] with-variable ;
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+SYMBOL: predicate-engines
+
: sort-methods ( assoc -- assoc' )
>alist [ keys sort-classes ] keep extract-keys ;
: quote-methods ( assoc -- assoc' )
[ 1quotation \ drop prefix ] assoc-map ;
+: find-predicate-engine ( classes -- word )
+ predicate-engines get [ at ] curry map-find drop ;
+
+: next-predicate-engine ( engine -- word )
+ class>> superclasses
+ find-predicate-engine
+ default get or ;
+
: methods-with-default ( engine -- assoc )
- methods>> clone default get object bootstrap-word pick set-at ;
+ [ methods>> clone ] [ next-predicate-engine ] bi
+ object bootstrap-word pick set-at ;
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
@@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine
: class-predicates ( assoc -- assoc )
[ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
-PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
-
: <predicate-engine-word> ( -- word )
generic-word get name>> "/predicate-engine" append f <word>
dup generic-word get "owner-generic" set-word-prop ;
@@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
[ <predicate-engine-word> ] dip
[ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
-M: predicate-engine compile-engine
+: compile-predicate-engine ( engine -- word )
methods-with-default
sort-methods
quote-methods
@@ -225,6 +236,10 @@ M: predicate-engine compile-engine
class-predicates
[ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+M: predicate-engine compile-engine
+ [ compile-predicate-engine ] [ class>> ] bi
+ [ drop ] [ predicate-engines get set-at ] 2bi ;
+
M: word compile-engine ;
M: f compile-engine ;
@@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f )
M: single-combination perform-combination
[
+ H{ } clone predicate-engines set
dup generic-word set
dup build-decision-tree
[ "decision-tree" set-word-prop ]
From ca6cbbb2f9ef1a849bb8a5e40e52a97862d8e171 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Wed, 13 May 2009 17:03:41 -0500
Subject: [PATCH 22/24] tools.annotations: now prints a table of values
---
basis/tools/annotations/annotations.factor | 28 +++++++---------------
1 file changed, 8 insertions(+), 20 deletions(-)
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 2639d48be2..3cb74fb00b 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -43,29 +43,17 @@ PRIVATE>
<PRIVATE
-: word-inputs ( word -- seq )
- stack-effect [
- [ datastack ] dip in>> length tail*
- ] [
- datastack
- ] if* ;
+: stack-values ( names -- alist )
+ [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-: entering ( str -- )
- "/-- Entering: " write dup .
- word-inputs stack.
- "\\--" print flush ;
+: trace-message ( word quot str -- )
+ "--- " write write bl over .
+ [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
+ [ simple-table. ] unless-empty flush ; inline
-: word-outputs ( word -- seq )
- stack-effect [
- [ datastack ] dip out>> length tail*
- ] [
- datastack
- ] if* ;
+: entering ( str -- ) [ in>> ] "Entering" trace-message ;
-: leaving ( str -- )
- "/-- Leaving: " write dup .
- word-outputs stack.
- "\\--" print flush ;
+: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
: (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ;
From c566708612c63a98abcc78bc34fd415a936b5de7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 13 May 2009 17:29:14 -0500
Subject: [PATCH 23/24] mason.common: fix git-id word on Windows
---
extra/mason/common/common.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index bc1b182734..a33e3c5831 100755
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -79,8 +79,8 @@ SYMBOL: stamp
with-directory ;
: git-id ( -- id )
- { "git" "show" } utf8 [ readln ] with-process-reader
- " " split second ;
+ { "git" "show" } utf8 [ lines ] with-process-reader
+ first " " split second ;
: ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ;
From 6af3332c4094fa413494b72eb8424ab123126451 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Wed, 13 May 2009 18:19:30 -0500
Subject: [PATCH 24/24] New mason.notify.server tool, and fix failure report
---
extra/mason/notify/notify.factor | 6 +-
extra/mason/notify/server/authors.txt | 1 +
extra/mason/notify/server/server.factor | 82 +++++++++++++++++++++++++
extra/mason/report/report.factor | 2 +-
4 files changed, 88 insertions(+), 3 deletions(-)
create mode 100644 extra/mason/notify/server/authors.txt
create mode 100644 extra/mason/notify/server/server.factor
diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
index 30da0c8286..ccabccdf8b 100644
--- a/extra/mason/notify/notify.factor
+++ b/extra/mason/notify/notify.factor
@@ -42,8 +42,10 @@ IN: mason.notify
: notify-report ( status -- )
[ "Build finished with status: " write . flush ]
[
- [ "report" utf8 file-contents ] dip email-report
- "report" { "report" } status-notify
+ [ "report" ] dip
+ [ [ utf8 file-contents ] dip email-report ]
+ [ "report" swap name>> 2array status-notify ]
+ 2bi
] bi ;
: notify-release ( archive-name -- )
diff --git a/extra/mason/notify/server/authors.txt b/extra/mason/notify/server/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/mason/notify/server/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor
new file mode 100644
index 0000000000..57c6d04300
--- /dev/null
+++ b/extra/mason/notify/server/server.factor
@@ -0,0 +1,82 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.smart command-line db
+db.sqlite db.tuples db.types io kernel namespaces sequences ;
+IN: mason.notify.server
+
+CONSTANT: +starting+ "starting"
+CONSTANT: +make-vm+ "make-vm"
+CONSTANT: +boot+ "boot"
+CONSTANT: +test+ "test"
+CONSTANT: +clean+ "clean"
+CONSTANT: +dirty+ "dirty"
+
+TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+
+builder "BUILDERS" {
+ { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+ { "os" "OS" TEXT +user-assigned-id+ }
+ { "cpu" "CPU" TEXT +user-assigned-id+ }
+ { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+ { "last-git-id" "LAST_GIT_ID" TEXT }
+ { "last-report" "LAST_REPORT" TEXT }
+ { "current-git-id" "CURRENT_GIT_ID" TEXT }
+ { "status" "STATUS" TEXT }
+} define-persistent
+
+SYMBOLS: host-name target-os target-cpu message message-arg ;
+
+: parse-args ( command-line -- )
+ dup peek message-arg set
+ [
+ {
+ [ host-name set ]
+ [ target-os set ]
+ [ target-cpu set ]
+ [ message set ]
+ } spread
+ ] input<sequence ;
+
+: find-builder ( -- builder )
+ builder new
+ host-name get >>host-name
+ target-os get >>os
+ target-cpu get >>cpu
+ dup select-tuple [ ] [ dup insert-tuple ] ?if ;
+
+: git-id ( builder id -- )
+ >>current-git-id +starting+ >>status drop ;
+
+: make-vm ( builder -- ) +make-vm+ >>status drop ;
+
+: boot ( report -- ) +boot+ >>status drop ;
+
+: test ( report -- ) +test+ >>status drop ;
+
+: report ( builder status content -- )
+ [ >>status ] [ >>last-report ] bi*
+ dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
+ dup current-git-id>> >>last-git-id
+ drop ;
+
+: update-builder ( builder -- )
+ message get {
+ { "git-id" [ message-arg get git-id ] }
+ { "make-vm" [ make-vm ] }
+ { "boot" [ boot ] }
+ { "test" [ test ] }
+ { "report" [ message-arg get contents report ] }
+ } case ;
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: handle-update ( command-line -- )
+ mason-db [
+ parse-args find-builder
+ [ update-builder ] [ update-tuple ] bi
+ ] with-db ;
+
+: main ( -- )
+ command-line get handle-update ;
+
+MAIN: main
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 6e48e7cf04..1b5aaf39ec 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -34,7 +34,7 @@ IN: mason.report
:: failed-report ( error file what -- status )
[
error [ error. ] with-string-writer :> error
- file utf8 file-contents 400 short tail* :> output
+ file utf8 file-lines 400 short tail* :> output
[XML
<h2><-what-></h2>