Merge branch 'master' of git://factorcode.org/git/factor

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
+[ -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

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*
+        2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
-        [ swap nth value-info class>> dup ] dip
+            [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
-        specific-method
+            [ swap nth value-info class>> dup ] dip
+            specific-method
+        ] if
     ] if ;
 
 : inline-standard-method ( #call word -- ? )

basis/tools/annotations/annotations.factor

@@ -43,29 +43,17 @@ PRIVATE>
 
 <PRIVATE
 
-: word-inputs ( word -- seq )
+: stack-values ( names -- alist )
-    stack-effect [
+    [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-        [ datastack ] dip in>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: entering ( str -- )
+: trace-message ( word quot str -- )
-    "/-- Entering: " write dup .
+    "--- " write write bl over .
-    word-inputs stack.
+    [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
-    "\\--" print flush ;
+    [ simple-table. ] unless-empty flush ; inline
 
-: word-outputs ( word -- seq )
+: entering ( str -- ) [ in>> ] "Entering" trace-message ;
-    stack-effect [
-        [ datastack ] dip out>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: leaving ( str -- )
+: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
-    "/-- Leaving: " write dup .
-    word-outputs stack.
-     "\\--" print flush ;
 
 : (watch) ( word def -- def )
     over '[ _ entering @ _ leaving ] ;

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" }
+    { "dev_t"     "st_dev" }
-    { "ushort"     "__pad1" }
+    { "ino_t"     "st_ino" }
-    { "__ino_t"     "__st_ino" }
+    { "nlink_t"   "st_nlink" }
-    { "mode_t"     "st_mode" }
+    { "mode_t"    "st_mode" }
-    { "nlink_t"    "st_nlink" }
+    { "uid_t"     "st_uid" }
-    { "uid_t"      "st_uid" }
+    { "gid_t"     "st_gid" }
-    { "gid_t"      "st_gid" }
+    { "int"       "pad0" }
-    { "dev_t"      "st_rdev" }
+    { "dev_t"     "st_rdev" }
-    { { "ushort" 2 } "__pad2" }
+    { "off64_t"     "st_size" }
-    { "off64_t"    "st_size" }
+    { "blksize_t" "st_blksize" }
-    { "blksize_t"  "st_blksize" }
+    { "blkcnt64_t"  "st_blocks" }
-    { "blkcnt64_t" "st_blocks" }
+    { "timespec"  "st_atimespec" }
-    { "timespec"   "st_atimespec" }
+    { "timespec"  "st_mtimespec" }
-    { "timespec"   "st_mtimespec" }
+    { "timespec"  "st_ctimespec" }
-    { "timespec"   "st_ctimespec" }
+    { "long"      "__unused0" }
-    { "ulonglong"  "st_ino" } ;
+    { "long"      "__unused1" }
+    { "long"      "__unused2" } ;
 
 FUNCTION: int __xstat64  ( int ver, char* pathname, stat* buf ) ;
 FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;

core/classes/predicate/predicate-tests.factor

@@ -1,5 +1,6 @@
-USING: math tools.test classes.algebra words kernel sequences assocs ;
+USING: math tools.test classes.algebra words kernel sequences assocs
-IN: classes.predicate
+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
+[ 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

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
+[ 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

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 -- )
-    [
+    dupd [
-        [ H{ } clone <predicate-engine> ] unless*
+        [ ] [ 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 ]

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? ;

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

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 ;

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 ;

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)

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> {
+    try-connect [
-        [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+        [ irc> ] dip >>stream t >>is-running
-        [ (>>stream) ]
+        in-messages>> [ irc-connected ] dip mailbox-put
-        [ t swap (>>is-running) ]
+    ] [ (terminate-irc) ] if* ;
-        [ in-messages>> [ irc-connected ] dip mailbox-put ]
-    } cleave ;
 
 : (do-login) ( -- ) irc> nick>> /LOGIN ;
 
@@ -52,7 +68,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 ;
@@ -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) ( -- )
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
-    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 ;

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 ;
 
@@ -35,3 +41,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 ;

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 ;
@@ -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 ;
 

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 ]

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
+  string>irc-message f >>timestamp ] unit-test
+
+{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :
ACTION jumps!
"
+        string>irc-message action? ] unit-test

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? ;
+M: ctcp post-process-irc-message ( ctcp -- )
-PREDICATE: participant-mode < channel-mode parameter>> ;
+    [ rest but-last ] change-text drop ;
+
+M: action post-process-irc-message ( action -- )
+    [ 7 tail ] change-text call-next-method ;

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
-    now >>timestamp dup sender >>sender ;
+    dup sender >>sender ;

extra/mason/common/common.factor

@@ -79,8 +79,8 @@ SYMBOL: stamp
     with-directory ;
 
 : git-id ( -- id )
-    { "git" "show" } utf8 [ readln ] with-process-reader
+    { "git" "show" } utf8 [ lines ] with-process-reader
-    " " split second ;
+    first " " split second ;
 
 : ?prepare-build-machine ( -- )
     builds/factor exists? [ prepare-build-machine ] unless ;

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" ] dip
-        "report" { "report" } status-notify
+        [ [ utf8 file-contents ] dip email-report ]
+        [ "report" swap name>> 2array status-notify ]
+        2bi
     ] bi ;
 
 : notify-release ( archive-name -- )

extra/mason/notify/server/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

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>

extra/redis/assoc/assoc.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel redis sequences ;
+IN: redis.assoc
+
+INSTANCE: redis assoc
+
+M: redis at* [ redis-get dup >boolean ] with-redis ;
+
+M: redis assoc-size [ redis-dbsize ] with-redis ;
+
+M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
+
+M: redis set-at [ redis-set drop ] with-redis ;
+
+M: redis delete-at [ redis-del drop ] with-redis ;
+
+M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
+
+M: redis equal? assoc= ;
+
+M: redis hashcode* assoc-hashcode ;

extra/redis/assoc/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/redis/assoc/summary.txt

@@ -0,0 +1 @@
+Assoc protocol implementation for Redis

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 ;
+USING: accessors io io.encodings.8-bit io.sockets
+io.streams.duplex kernel redis.command-writer
+redis.response-parser splitting ;
 IN: redis
 
 #! Connection
@@ -23,7 +25,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 ;
@@ -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

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();

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);

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... */
+namespace
-static cell frame_count;
-
-void count_stack_frame(stack_frame *frame)
 {
-	frame_count += 2; 
-}
 
-static cell frame_index;
+struct stack_frame_counter {
-static array *frames;
+	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;
+	stack_frame_counter counter;
-	iterate_callstack_object(callstack.untagged(),count_stack_frame);
+	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;
+	dpush(tag<array>(accum.frames));
-	iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
-
-	dpush(tag<array>(frames));
 }
 
 stack_frame *innermost_stack_frame(callstack *stack)

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);
+}
+
 }

vm/code_heap.cpp

@@ -173,8 +173,7 @@ void forward_object_xts()
 		}
 	}
 
-	/* End the heap scan */
+	end_scan();
-	gc_off = false;
 }
 
 /* Set the XT fields now that the heap has been compacted */
@@ -203,8 +202,7 @@ void fixup_object_xts()
 		}
 	}
 
-	/* End the heap scan */
+	end_scan();
-	gc_off = false;
 }
 
 /* Move all free space to the end of the code heap. This is not very efficient,

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)
-	{
+		functor(tagged<object>(obj));
-		if(tagged<object>(obj).type_p(WORD_TYPE))
+	end_scan();
-			words.add(obj);
+}
-	}
 
-	/* End heap scan */
+namespace
-	gc_off = false;
+{
 
-	words.trim();
+struct word_counter {
-	return words.elements.value();
+	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();
 }
 
 }

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);

vm/debug.cpp

@@ -253,8 +253,7 @@ void dump_objects(cell type)
 		}
 	}
 
-	/* end scan */
+	end_scan();
-	gc_off = false;
 }
 
 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 */
+	end_scan();
-	gc_off = false;
 }
 
 /* Dump all code blocks for debugging */

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;

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

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;

vm/os-linux.hpp

@@ -3,8 +3,8 @@
 namespace factor
 {
 
-int inotify_init();
+VM_C_API int 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);
-int inotify_rm_watch(int fd, u32 wd);
+VM_C_API int inotify_rm_watch(int fd, u32 wd);
 
 }

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_FORMAT "%lu"
-#define cell_HEX_FORMAT "%lx"
+#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"

vm/os-windows.hpp

@@ -22,14 +22,14 @@ typedef wchar_t vm_char;
 #define FSEEK fseek
 
 #ifdef WIN64
-	#define cell_FORMAT "%Iu"
+	#define CELL_FORMAT "%Iu"
-	#define cell_HEX_FORMAT "%Ix"
+	#define CELL_HEX_FORMAT "%Ix"
-	#define cell_HEX_PAD_FORMAT "%016Ix"
+	#define CELL_HEX_PAD_FORMAT "%016Ix"
 	#define FIXNUM_FORMAT "%Id"
 #else
-	#define cell_FORMAT "%lu"
+	#define CELL_FORMAT "%lu"
-	#define cell_HEX_FORMAT "%lx"
+	#define CELL_HEX_FORMAT "%lx"
-	#define cell_HEX_PAD_FORMAT "%08lx"
+	#define CELL_HEX_PAD_FORMAT "%08lx"
 	#define FIXNUM_FORMAT "%ld"
 #endif
 

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;
 };