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

basis/editors/macvim/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/editors/macvim/macvim.factor

@@ -0,0 +1,13 @@
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.macvim
+
+: macvim-location ( file line -- )
+    drop
+    [ "open" , "-a" , "MacVim", , ] { } make
+    try-process ;
+
+[ macvim-location ] edit-hook set-global
+
+

basis/editors/macvim/summary.txt

@@ -0,0 +1 @@
+MacVim editor integration

basis/editors/macvim/tags.txt

@@ -0,0 +1 @@
+unportable

basis/editors/textedit/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/editors/textedit/summary.txt

@@ -0,0 +1 @@
+TextEdit editor integration

basis/editors/textedit/tags.txt

@@ -0,0 +1 @@
+unportable

basis/editors/textedit/textedit.factor

@@ -0,0 +1,13 @@
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.textedit
+
+: textedit-location ( file line -- )
+    drop
+    [ "open" , "-a" , "TextEdit", , ] { } make
+    try-process ;
+
+[ textedit-location ] edit-hook set-global
+
+

basis/furnace/actions/actions.factor

@@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ;
         begin-conversation
         nested-forms-key param " " split harvest nested-forms cset
         form get form cset
-        <redirect>
+        <continue-conversation>
     ] [ <400> ] if*
     exit-with ;
 

basis/furnace/alloy/alloy.factor

@@ -3,6 +3,7 @@
 USING: kernel sequences db.tuples alarms calendar db fry
 furnace.db
 furnace.cache
+furnace.asides
 furnace.referrer
 furnace.sessions
 furnace.conversations
@@ -12,13 +13,14 @@ IN: furnace.alloy
 
 : <alloy> ( responder db params -- responder' )
     '[
+        <asides>
         <conversations>
         <sessions>
         _ _ <db-persistence>
         <check-form-submissions>
     ] call ;
 
-: state-classes { session conversation permit } ; inline
+: state-classes { session aside conversation permit } ; inline
 
 : init-furnace-tables ( -- )
     state-classes ensure-tables

basis/furnace/asides/asides.factor

@@ -0,0 +1,111 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel sequences accessors hashtables
+urls db.types db.tuples math.parser fry logging combinators
+html.templates.chloe.syntax
+http http.server http.server.filters http.server.redirection
+furnace
+furnace.cache
+furnace.sessions
+furnace.redirection ;
+IN: furnace.asides
+
+TUPLE: aside < server-state
+session method url post-data ;
+
+: <aside> ( id -- aside )
+    aside new-server-state ;
+
+aside "ASIDES" {
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "method" "METHOD" { VARCHAR 10 } }
+    { "url" "URL" URL }
+    { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+: aside-id-key "__a" ;
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+    asides new-server-state-manager ;
+
+SYMBOL: aside-id
+
+: get-aside ( id -- aside )
+    dup [ aside get-state ] when check-session ;
+
+: request-aside-id ( request -- id )
+    aside-id-key swap request-params at string>number ;
+
+: request-aside ( request -- aside )
+    request-aside-id get-aside ;
+
+: set-aside ( aside -- )
+    [ id>> aside-id set ] when* ;
+
+: init-asides ( asides -- )
+    asides set
+    request get request-aside-id
+    get-aside
+    set-aside ;
+
+M: asides call-responder*
+    [ init-asides ] [ asides set ] [ call-next-method ] tri ;
+
+: touch-aside ( aside -- )
+    asides get touch-state ;
+
+: begin-aside ( url -- )
+    f <aside>
+        swap >>url
+        session get id>> >>session
+        request get method>> >>method
+        request get post-data>> >>post-data
+    [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
+
+: end-aside-post ( aside -- response )
+    [ url>> ] [ post-data>> ] bi
+    request [
+        clone
+            swap >>post-data
+            over >>url
+    ] change
+    [ url set ] [ path>> split-path ] bi
+    asides get responder>> call-responder ;
+
+\ end-aside-post DEBUG add-input-logging
+
+ERROR: end-aside-in-get-error ;
+
+: move-on ( id -- response )
+    post-request? [ end-aside-in-get-error ] unless
+    dup method>> {
+        { "GET" [ url>> <redirect> ] }
+        { "HEAD" [ url>> <redirect> ] }
+        { "POST" [ end-aside-post ] }
+    } case ;
+
+: end-aside ( default -- response )
+    aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
+
+M: asides link-attr ( tag -- )
+    drop
+    "aside" optional-attr {
+        { "none" [ aside-id off ] }
+        { "begin" [ url get begin-aside ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+M: asides modify-query ( query asides -- query' )
+    drop
+    aside-id get [
+        aside-id-key associate assoc-union
+    ] when* ;
+
+M: asides modify-form ( asides -- )
+    drop
+    aside-id get
+    aside-id-key
+    hidden-form-field ;

basis/furnace/auth/features/deactivate-user/deactivate-user.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs namespaces accessors db db.tuples urls
 http.server.dispatchers
-furnace.conversations
+furnace.asides
 furnace.actions
 furnace.auth
 furnace.auth.providers ;

basis/furnace/auth/features/edit-profile/edit-profile.factor

@@ -3,8 +3,8 @@
 USING: kernel accessors namespaces sequences assocs
 validators urls html.forms http.server.dispatchers
 furnace.auth
-furnace.actions
+furnace.asides
-furnace.conversations ;
+furnace.actions ;
 IN: furnace.auth.features.edit-profile
 
 : <edit-profile-action> ( -- action )

basis/furnace/auth/features/recover-password/recover-password.factor

@@ -19,7 +19,7 @@ SYMBOL: lost-password-from
         [ username>> "username" set-query-param ]
         [ ticket>> "ticket" set-query-param ]
         bi
-    adjust-url relative-to-request ;
+    adjust-url ;
 
 : password-email ( user -- email )
     <email>

basis/furnace/auth/login/login.factor

@@ -5,6 +5,7 @@ calendar validators urls logging html.forms
 http http.server http.server.dispatchers
 furnace
 furnace.auth
+furnace.asides
 furnace.actions
 furnace.sessions
 furnace.utilities
@@ -93,9 +94,15 @@ SYMBOL: capabilities
         [ logout ] >>submit ;
 
 M: login-realm login-required* ( description capabilities login -- response )
-    begin-aside
+    begin-conversation
-    [ description cset ] [ capabilities cset ] [ drop ] tri*
+    [ description cset ] [ capabilities cset ] [ secure>> ] tri*
-    URL" $realm/login" >secure-url <redirect> ;
+    [
+        url get >secure-url begin-aside
+        URL" $realm/login" >secure-url <continue-conversation>
+    ] [
+        url get begin-aside
+        URL" $realm/login" <continue-conversation>
+    ] if ;
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm

basis/furnace/chloe-tags/chloe-tags.factor

@@ -37,7 +37,7 @@ IN: furnace.chloe-tags
         <url>
             swap parse-query-attr >>query
             -rot a-url-path >>path
-        adjust-url relative-to-request
+        adjust-url
     ] if ;
 
 : compile-a-url ( tag -- )

basis/furnace/conversations/conversations.factor

@@ -11,18 +11,13 @@ furnace.sessions
 furnace.redirection ;
 IN: furnace.conversations
 
-TUPLE: conversation < scope
+TUPLE: conversation < scope session ;
-session
-method url post-data ;
 
-: <conversation> ( id -- aside )
+: <conversation> ( id -- conversation )
     conversation new-server-state ;
 
 conversation "CONVERSATIONS" {
     { "session" "SESSION" BIG-INTEGER +not-null+ }
-    { "method" "METHOD" { VARCHAR 10 } }
-    { "url" "URL" URL }
-    { "post-data" "POST_DATA" FACTOR-BLOB }
 } define-persistent
 
 : conversation-id-key "__c" ;
@@ -46,8 +41,7 @@ SYMBOL: conversation-id
     conversation get scope-change ; inline
 
 : get-conversation ( id -- conversation )
-    dup [ conversation get-state ] when
+    dup [ conversation get-state ] when check-session ;
-    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
 
 : request-conversation-id ( request -- id )
     conversation-id-key swap request-params at string>number ;
@@ -88,22 +82,21 @@ M: conversations call-responder*
 : add-conversation ( conversation -- )
     [ touch-conversation ] [ insert-tuple ] bi ;
 
-: begin-conversation* ( -- conversation )
-    empty-conversastion dup add-conversation ;
-
 : begin-conversation ( -- )
     conversation get [
-        begin-conversation*
+        empty-conversastion
-        set-conversation
+        [ add-conversation ]
+        [ set-conversation ] bi
     ] unless ;
 
 : end-conversation ( -- )
     conversation off
     conversation-id off ;
 
-: <conversation-redirect> ( url seq -- response )
+: <continue-conversation> ( url -- response )
-    begin-conversation
+    conversation-id get
-    [ [ get ] keep cset ] each
+    conversation-id-key
+    set-query-param
     <redirect> ;
 
 : restore-conversation ( seq -- )
@@ -114,64 +107,6 @@ M: conversations call-responder*
         bi
     ] [ 2drop ] if ;
 
-: begin-aside ( -- )
-    begin-conversation
-    conversation get
-        request get
-        [ method>> >>method ]
-        [ url>> >>url ]
-        [ post-data>> >>post-data ]
-        tri
-    touch-conversation ;
-
-: end-aside-post ( aside -- response )
-    request [
-        clone
-            over post-data>> >>post-data
-            over url>> >>url
-    ] change
-    [ url>> url set ]
-    [ url>> path>> split-path ] bi
-    conversations get responder>> call-responder ;
-
-\ end-aside-post DEBUG add-input-logging
-
-ERROR: end-aside-in-get-error ;
-
-: move-on ( id -- response )
-    post-request? [ end-aside-in-get-error ] unless
-    dup method>> {
-        { "GET" [ url>> <redirect> ] }
-        { "HEAD" [ url>> <redirect> ] }
-        { "POST" [ end-aside-post ] }
-    } case ;
-
-: get-aside ( id -- conversation )
-    get-conversation dup [ dup method>> [ drop f ] unless ] when ;
-
-: end-aside* ( url id -- response )
-    get-aside [ move-on ] [ <redirect> ] ?if ;
-
-: end-aside ( default -- response )
-    conversation-id get
-    end-conversation
-    end-aside* ;
-
-M: conversations link-attr ( tag -- )
-    drop
-    "aside" optional-attr {
-        { "none" [ conversation-id off ] }
-        { "begin" [ begin-aside ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;
-
-M: conversations modify-query ( query conversations -- query' )
-    drop
-    conversation-id get [
-        conversation-id-key associate assoc-union
-    ] when* ;
-
 M: conversations modify-form ( conversations -- )
     drop
     conversation-id get

basis/furnace/furnace.factor

@@ -37,6 +37,10 @@ GENERIC: modify-query ( query responder -- query' )
 
 M: object modify-query drop ;
 
+GENERIC: modify-redirect-query ( query responder -- query' )
+
+M: object modify-redirect-query drop ;
+
 GENERIC: adjust-url ( url -- url' )
 
 M: url adjust-url
@@ -47,6 +51,14 @@ M: url adjust-url
 
 M: string adjust-url ;
 
+GENERIC: adjust-redirect-url ( url -- url' )
+
+M: url adjust-redirect-url
+    adjust-url
+    [ [ modify-redirect-query ] each-responder ] change-query ;
+
+M: string adjust-redirect-url ;
+
 GENERIC: link-attr ( tag responder -- )
 
 M: object link-attr 2drop ;

basis/furnace/redirection/redirection.factor

@@ -7,7 +7,7 @@ http.server.filters furnace ;
 IN: furnace.redirection
 
 : <redirect> ( url -- response )
-    adjust-url request get method>> {
+    adjust-redirect-url request get method>> {
         { "GET" [ <temporary-redirect> ] }
         { "HEAD" [ <temporary-redirect> ] }
         { "POST" [ <permanent-redirect> ] }

basis/furnace/sessions/sessions.factor

@@ -107,3 +107,8 @@ M: sessions call-responder* ( path responder -- response )
     sessions set
     request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
+
+SLOT: session
+
+: check-session ( state/f -- state/f )
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;

basis/furnace/syndication/syndication.factor

@@ -32,7 +32,7 @@ M: object >entry
 : process-entries ( seq -- seq' )
     20 short head-slice [
         >entry clone
-        [ adjust-url relative-to-request ] change-url
+        [ adjust-url ] change-url
     ] map ;
 
 : <feed-content> ( body -- response )
@@ -46,7 +46,7 @@ TUPLE: feed-action < action title url entries ;
             feed new
                 _
                 [ title>> call >>title ]
-                [ url>> call adjust-url relative-to-request >>url ]
+                [ url>> call adjust-url >>url ]
                 [ entries>> call process-entries >>entries ]
                 tri
             <feed-content>

basis/html/components/components.factor

@@ -144,19 +144,22 @@ M: code render*
     [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
 
 ! Farkup component
-TUPLE: farkup no-follow disable-images ;
+TUPLE: farkup no-follow disable-images parsed ;
 
 : string>boolean ( string -- boolean )
     {
         { "true" [ t ] }
         { "false" [ f ] }
+        { f [ f ] }
     } case ;
 
 M: farkup render*
     [
+        nip
         [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
-        [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
+        [ disable-images>> [ string>boolean disable-images? set ] when* ]
-        drop string-lines "\n" join write-farkup
+        [ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
+        tri
     ] with-scope ;
 
 ! Inspector component

basis/regexp/regexp.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math math.ranges
+USING: accessors combinators kernel math math.ranges sequences
-sequences regexp.backend regexp.utils memoize sets
+sets assocs prettyprint.backend make lexer namespaces parser
-regexp.parser regexp.nfa regexp.dfa regexp.traversal
+arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
-regexp.transition-tables assocs prettyprint.backend
+regexp.dfa regexp.traversal regexp.transition-tables ;
-make lexer namespaces parser ;
 IN: regexp
 
 : default-regexp ( string -- regexp )
@@ -47,6 +46,33 @@ IN: regexp
         [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
     ] if ;
 
+: first-match ( string regexp -- pair/f )
+    0 swap match-range dup [ 2array ] [ 2drop f ] if ;
+
+: re-cut ( string regexp -- end/f start )
+    dupd first-match
+    [ [ second tail-slice ] [ first head ] 2bi ]
+    [ "" like f swap ]
+    if* ;
+
+: re-split ( string regexp -- seq )
+    [ dup ] swap '[ _ re-cut ] [ ] produce nip ;
+
+: re-replace ( string regexp replacement -- result )
+    [ re-split ] dip join ;
+
+: next-match ( string regexp -- end/f match/f )
+    dupd first-match dup
+    [ [ second tail-slice ] keep ]
+    [ 2drop f f ]
+    if ;
+
+: all-matches ( string regexp -- seq )
+    [ dup ] swap '[ _ next-match ] [ ] produce nip ;
+
+: count-matches ( string regexp -- n )
+    all-matches length 1- ;
+
 : initial-option ( regexp option -- regexp' )
     over options>> conjoin ;
 
@@ -102,8 +128,6 @@ IN: regexp
 : option? ( option regexp -- ? )
     options>> key? ;
 
-USE: multiline
-/*
 M: regexp pprint*
     [
         [
@@ -112,4 +136,3 @@ M: regexp pprint*
             case-insensitive swap option? [ "i" % ] when
         ] "" make
     ] keep present-text ;
-*/

basis/stack-checker/errors/errors.factor

@@ -72,8 +72,8 @@ TUPLE: effect-error word inferred declared ;
 M: effect-error error.
     "Stack effects of the word " write
     [ word>> pprint " do not match." print ]
-    [ "Inferred: " write inferred>> effect>string . ]
+    [ "Inferred: " write inferred>> . ]
-    [ "Declared: " write declared>> effect>string . ] tri ;
+    [ "Declared: " write declared>> . ] tri ;
 
 TUPLE: recursive-quotation-error quot ;
 

extra/benchmark/regex-dna/regex-dna-test-out.txt

@@ -0,0 +1,13 @@
+agggtaaa|tttaccct 0
+[cgt]gggtaaa|tttaccc[acg] 3
+a[act]ggtaaa|tttacc[agt]t 9
+ag[act]gtaaa|tttac[agt]ct 8
+agg[act]taaa|ttta[agt]cct 10
+aggg[acg]aaa|ttt[cgt]ccct 3
+agggt[cgt]aa|tt[acg]accct 4
+agggta[cgt]a|t[acg]taccct 3
+agggtaa[cgt]|[acg]ttaccct 5
+
+101745
+100000
+133640

extra/benchmark/regex-dna/regex-dna-tests.factor

@@ -0,0 +1,10 @@
+USING: benchmark.regex-dna io io.files io.encodings.ascii
+io.streams.string kernel tools.test ;
+IN: benchmark.regex-dna.tests
+
+[ t ] [
+    "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
+    [ regex-dna ] with-string-writer
+    "resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
+    ascii file-contents =
+] unit-test

extra/benchmark/regex-dna/regex-dna.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors regexp prettyprint io io.encodings.ascii
+io.files kernel sequences assocs namespaces ;
+IN: benchmark.regex-dna
+
+! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
+
+: strip-line-breaks ( string -- string' )
+    R/ >.*\n|\n/ "" re-replace ;
+
+: count-patterns ( string -- )
+    {
+        R/ agggtaaa|tttaccct/i,
+        R/ [cgt]gggtaaa|tttaccc[acg]/i,
+        R/ a[act]ggtaaa|tttacc[agt]t/i,
+        R/ ag[act]gtaaa|tttac[agt]ct/i,
+        R/ agg[act]taaa|ttta[agt]cct/i,
+        R/ aggg[acg]aaa|ttt[cgt]ccct/i,
+        R/ agggt[cgt]aa|tt[acg]accct/i,
+        R/ agggta[cgt]a|t[acg]taccct/i,
+        R/ agggtaa[cgt]|[acg]ttaccct/i
+    } [
+        [ raw>> write bl ]
+        [ count-matches . ]
+        bi
+    ] with each ;
+
+: do-replacements ( string -- string' )
+    {
+        { R/ B/ "(c|g|t)" }
+        { R/ D/ "(a|g|t)" }
+        { R/ H/ "(a|c|t)" }
+        { R/ K/ "(g|t)" }
+        { R/ M/ "(a|c)" }
+        { R/ N/ "(a|c|g|t)" }
+        { R/ R/ "(a|g)" }
+        { R/ S/ "(c|t)" }
+        { R/ V/ "(a|c|g)" }
+        { R/ W/ "(a|t)" }
+        { R/ Y/ "(c|t)" }
+    } [ re-replace ] assoc-each ;
+
+SYMBOL: ilen
+SYMBOL: clen
+
+: regex-dna ( file -- )
+    ascii file-contents dup length ilen set
+    strip-line-breaks dup length clen set
+    dup count-patterns
+    do-replacements
+    nl
+    ilen get .
+    clen get .
+    length . ;
+
+: regex-dna-main ( -- )
+    "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
+
+MAIN: regex-dna-main

extra/irc/client/client-tests.factor

@@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- )
     [ [ last-line>> concat ] [ lines>> ] bi push ] keep
     V{ } clone >>last-line drop ;
 
-: spawn-client ( lines listeners -- irc-client )
+: spawn-client ( -- irc-client )
     "someserver" irc-port "factorbot" f <irc-profile>
     <irc-client>
         t >>is-running

extra/irc/client/client.factor

@@ -68,12 +68,17 @@ SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
 
+<PRIVATE
+: end-loops ( irc-client -- )
+     [ listeners>> values [ out-messages>> ] map ]
+     [ in-messages>> ]
+     [ out-messages>> ] tri 2array prepend
+     [ irc-end swap mailbox-put ] each ;
+PRIVATE>
+
 : terminate-irc ( irc-client -- )
     [ is-running>> ] keep and [
-        [ [ irc-end ] dip in-messages>> mailbox-put ]
+        [ end-loops ] [ [ f ] dip (>>is-running) ] bi
-        [ [ f ] dip (>>is-running) ]
-        [ stream>> dispose ]
-        tri
     ] when* ;
 
 <PRIVATE
@@ -90,7 +95,8 @@ SYMBOL: current-irc-client
 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
-
+: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
+: me? ( string -- ? ) irc> profile>> nickname>> = ;
 
 GENERIC: to-listener ( message obj -- )
 
@@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- )
     swap dup listeners-with-participant [ rename-participant ] with with each ;
 
 : add-participant ( mode nick channel -- )
-    listener> [
+    listener>
     [ participants>> set-at ]
-        [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
+    [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
-    ] [ 2drop ] if* ;
+
+: change-participant-mode ( channel mode nick -- )
+    rot listener>
+    [ participants>> set-at ]
+    [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
 
 DEFER: me?
 
@@ -174,14 +184,11 @@ DEFER: me?
 ! Server message handling
 ! ======================================
 
-: me? ( string -- ? )
-    irc> profile>> nickname>> = ;
-
 GENERIC: forward-name ( irc-message -- name )
 M: join forward-name ( join -- name ) trailing>> ;
 M: part forward-name ( part -- name ) channel>> ;
 M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) name>> ;
 M: privmsg forward-name ( privmsg -- name )
     dup name>> me? [ irc-message-sender ] [ name>> ] if ;
 
@@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- )
     name>> "_" append /NICK ;
 
 M: join process-message ( join -- )
-    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
+    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
+    dup listener> [ add-participant ] [ 3drop ] if ;
 
 M: part process-message ( part -- )
     [ irc-message-sender ] [ channel>> ] bi remove-participant ;
@@ -236,6 +244,12 @@ M: quit process-message ( quit -- )
 M: nick process-message ( nick -- )
     [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
 
+! M: mode process-message ( mode -- )
+!    [ channel-mode? ] keep and [
+!        [ name>> ] [ mode>> ] [ parameter>> ] tri
+!        [ change-participant-mode ] [ 2drop ] if*
+!    ] when* ;
+
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 
@@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- )
         [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
     ] [ drop ] if* ;
 
-: handle-incoming-irc ( irc-message -- )
-    [ forward-message ] [ process-message ] bi ;
-
 ! ======================================
 ! Client message handling
 ! ======================================
 
-: handle-outgoing-irc ( irc-message -- )
+GENERIC: handle-outgoing-irc ( irc-message -- ? )
-    irc-message>client-line irc-print ;
+M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
+M: irc-message handle-outgoing-irc ( irc-message -- ? )
+    irc-message>client-line irc-print t ;
 
 ! ======================================
 ! Reader/Writer
@@ -279,27 +292,28 @@ DEFER: (connect-irc)
 : handle-disconnect ( error -- )
     drop irc> is-running>> [ (handle-disconnect) ] when ;
 
-: (reader-loop) ( -- )
+: (reader-loop) ( -- ? )
     irc> stream>> [
         |dispose stream-readln [
-            parse-irc-line handle-reader-message
+            parse-irc-line handle-reader-message t
         ] [
-            irc> terminate-irc
+            irc> terminate-irc f
         ] if*
     ] with-destructors ;
 
 : reader-loop ( -- ? )
-    [ (reader-loop) ] [ handle-disconnect ] recover t ;
+    [ (reader-loop) ] [ handle-disconnect t ] recover ;
 
 : writer-loop ( -- ? )
-    irc> out-messages>> mailbox-get handle-outgoing-irc t ;
+    irc> out-messages>> mailbox-get handle-outgoing-irc ;
 
 ! ======================================
 ! Processing loops
 ! ======================================
 
 : in-multiplexer-loop ( -- ? )
-    irc> in-messages>> mailbox-get handle-incoming-irc t ;
+    irc> in-messages>> mailbox-get
+    [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
 
 : strings>privmsg ( name string -- privmsg )
     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@@ -310,22 +324,22 @@ DEFER: (connect-irc)
       [ nip ]
     } cond ;
 
+GENERIC: handle-listener-out ( irc-message -- ? )
+M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
+M: irc-message handle-listener-out ( irc-message -- ? )
+     irc> out-messages>> mailbox-put t ;
+    
 : listener-loop ( name -- ? )
     dup listener> [
         out-messages>> mailbox-get
-        maybe-annotate-with-name
+        maybe-annotate-with-name handle-listener-out
-        irc> out-messages>> mailbox-put
-        t
     ] [ drop f ] if* ;
 
-: spawn-irc-loop ( quot: ( -- ? ) name -- )
-    [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
-    spawn-server drop ;
-
 : spawn-irc ( -- )
-    [ reader-loop ] "irc-reader-loop" spawn-irc-loop
+    [ reader-loop ] "irc-reader-loop" spawn-server
-    [ writer-loop ] "irc-writer-loop" spawn-irc-loop
+    [ writer-loop ] "irc-writer-loop" spawn-server
-    [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+    [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
+    3drop ;
 
 ! ======================================
 ! Listener join request handling
@@ -333,7 +347,7 @@ DEFER: (connect-irc)
 
 : set+run-listener ( name irc-listener -- )
     over irc> listeners>> set-at
-    '[ _ listener-loop ] "listener" spawn-irc-loop ;
+    '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
 
 GENERIC: (add-listener) ( irc-listener -- )
 

extra/irc/messages/messages-tests.factor

@@ -6,54 +6,60 @@ IN: irc.messages.tests
 
 { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
 
-irc-message new
+{ T{ irc-message
-    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+     { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
-    "someuser!n=user@some.where" >>prefix
+     { prefix "someuser!n=user@some.where" }
-                       "PRIVMSG" >>command
+     { command  "PRIVMSG" }
-               { "#factortest" } >>parameters
+     { parameters { "#factortest" } }
-                            "hi" >>trailing
+     { trailing "hi" } } }
-1array
 [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
   string>irc-message f >>timestamp ] unit-test
 
-privmsg new
+{ T{ privmsg
-    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+     { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
-    "someuser!n=user@some.where" >>prefix
+     { prefix  "someuser!n=user@some.where" }
-                       "PRIVMSG" >>command
+     { command "PRIVMSG" }
-               { "#factortest" } >>parameters
+     { parameters { "#factortest" } }
-                            "hi" >>trailing
+     { trailing "hi" }
-                   "#factortest" >>name
+     { name "#factortest" } } }
-1array
 [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
   parse-irc-line f >>timestamp ] unit-test
 
-join new
+{ T{ join
-    ":someuser!n=user@some.where JOIN :#factortest" >>line
+     { line ":someuser!n=user@some.where JOIN :#factortest" }
-    "someuser!n=user@some.where" >>prefix
+     { prefix "someuser!n=user@some.where" }
-                          "JOIN" >>command
+     { command "JOIN" }
-                             { } >>parameters
+     { parameters { } }
-                   "#factortest" >>trailing
+     { trailing "#factortest" } } }
-1array
 [ ":someuser!n=user@some.where JOIN :#factortest"
   parse-irc-line f >>timestamp ] unit-test
 
-mode new
+{ T{ mode
-    ":ircserver.net MODE #factortest +ns" >>line
+     { line ":ircserver.net MODE #factortest +ns" }
-                          "ircserver.net" >>prefix
+     { prefix "ircserver.net" }
-                                   "MODE" >>command
+     { command "MODE" }
-                  { "#factortest" "+ns" } >>parameters
+     { parameters { "#factortest" "+ns" } }
-                            "#factortest" >>channel
+     { name "#factortest" }
-                                    "+ns" >>mode
+     { mode "+ns" } } }
-1array
 [ ":ircserver.net MODE #factortest +ns"
   parse-irc-line f >>timestamp ] unit-test
 
-nick new
+{ T{ mode
-    ":someuser!n=user@some.where NICK :someuser2" >>line
+     { line ":ircserver.net MODE #factortest +o someuser" }
-                     "someuser!n=user@some.where" >>prefix
+     { prefix "ircserver.net" }
-                                           "NICK" >>command
+     { command "MODE" }
-                                              { } >>parameters
+     { parameters { "#factortest" "+o" "someuser" } }
-                                      "someuser2" >>trailing
+     { name "#factortest" }
-1array
+     { mode "+o" }
+     { parameter "someuser" } } }
+[ ":ircserver.net MODE #factortest +o someuser"
+  parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick
+     { line ":someuser!n=user@some.where NICK :someuser2" }
+     { prefix "someuser!n=user@some.where" }
+     { command "NICK" }
+     { parameters  { } }
+     { trailing "someuser2" } } }
 [ ":someuser!n=user@some.where NICK :someuser2"
   parse-irc-line f >>timestamp ] unit-test

extra/irc/messages/messages.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry splitting ascii calendar accessors combinators qualified
-       arrays classes.tuple math.order quotations ;
+       arrays classes.tuple math.order ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
+EXCLUDE: inverse => _ ;
 IN: irc.messages
 
 TUPLE: irc-message line prefix command parameters trailing timestamp ;
@@ -18,8 +19,8 @@ TUPLE: kick < irc-message channel who ;
 TUPLE: roomlist < irc-message channel names ;
 TUPLE: nick-in-use < irc-message asterisk name ;
 TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message channel mode ;
+TUPLE: mode < irc-message name mode parameter ;
-TUPLE: names-reply < irc-message who = channel ;
+TUPLE: names-reply < irc-message who channel ;
 TUPLE: unhandled < irc-message ;
 
 : <irc-client-message> ( command parameters trailing -- irc-message )
@@ -28,41 +29,58 @@ TUPLE: unhandled < irc-message ;
 
 <PRIVATE
 
-GENERIC: irc-command-string ( irc-message -- string )
+GENERIC: command-string>> ( irc-message -- string )
 
-M: irc-message irc-command-string ( irc-message -- string ) command>> ;
+M: irc-message command-string>> ( irc-message -- string ) command>> ;
-M: ping        irc-command-string ( ping -- string )    drop "PING" ;
+M: ping        command-string>> ( ping -- string )    drop "PING" ;
-M: join        irc-command-string ( join -- string )    drop "JOIN" ;
+M: join        command-string>> ( join -- string )    drop "JOIN" ;
-M: part        irc-command-string ( part -- string )    drop "PART" ;
+M: part        command-string>> ( part -- string )    drop "PART" ;
-M: quit        irc-command-string ( quit -- string )    drop "QUIT" ;
+M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
-M: nick        irc-command-string ( nick -- string )    drop "NICK" ;
+M: nick        command-string>> ( nick -- string )    drop "NICK" ;
-M: privmsg     irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
+M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
-M: notice      irc-command-string ( notice -- string )  drop "NOTICE" ;
+M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
-M: mode        irc-command-string ( mode -- string )    drop "MODE" ;
+M: mode        command-string>> ( mode -- string )    drop "MODE" ;
-M: kick        irc-command-string ( kick -- string )    drop "KICK" ;
+M: kick        command-string>> ( kick -- string )    drop "KICK" ;
 
-GENERIC: irc-command-parameters ( irc-message -- seq )
+GENERIC: command-parameters>> ( irc-message -- seq )
 
-M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
+M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
-M: ping        irc-command-parameters ( ping -- seq )    drop { } ;
+M: ping        command-parameters>> ( ping -- seq )    drop { } ;
-M: join        irc-command-parameters ( join -- seq )    drop { } ;
+M: join        command-parameters>> ( join -- seq )    drop { } ;
-M: part        irc-command-parameters ( part -- seq )    channel>> 1array ;
+M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
-M: quit        irc-command-parameters ( quit -- seq )    drop { } ;
+M: quit        command-parameters>> ( quit -- seq )    drop { } ;
-M: nick        irc-command-parameters ( nick -- seq )    drop { } ;
+M: nick        command-parameters>> ( nick -- seq )    drop { } ;
-M: privmsg     irc-command-parameters ( privmsg -- seq ) name>> 1array ;
+M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
-M: notice      irc-command-parameters ( norice -- seq )  type>> 1array ;
+M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
-M: kick irc-command-parameters ( kick -- seq )
+M: kick command-parameters>> ( kick -- seq )
     [ channel>> ] [ who>> ] bi 2array ;
-M: mode irc-command-parameters ( mode -- seq )
+M: mode command-parameters>> ( mode -- seq )
     [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
 
+GENERIC: (>>command-parameters) ( params irc-message -- )
+
+M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
+M: logged-in (>>command-parameters) ( params part -- )  [ first ] dip (>>name) ;
+M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
+M: notice  (>>command-parameters) ( params notice -- )  [ first ] dip (>>type) ;
+M: part    (>>command-parameters) ( params part -- )
+    [ first ] dip (>>channel) ;
+M: kick    (>>command-parameters) ( params kick -- )
+    [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
+M: names-reply (>>command-parameters) ( params names-reply -- )
+    [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
+M: mode    (>>command-parameters) ( params mode -- )
+    { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
+      { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
+    } switch ;
+
 PRIVATE>
 
 GENERIC: irc-message>client-line ( irc-message -- string )
 
 M: irc-message irc-message>client-line ( irc-message -- string )
-    [ irc-command-string ]
+    [ command-string>> ]
-    [ irc-command-parameters " " sjoin ]
+    [ command-parameters>> " " sjoin ]
     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
     tri 3array " " sjoin ;
 
@@ -77,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 ! ======================================
 
 : split-at-first ( seq separators -- before after )
-    dupd '[ _ member? ] find
+    dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-        [ cut 1 tail ]
-        [ swap ]
-    if ;
 
 : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
 
@@ -96,6 +111,15 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 : split-trailing ( string -- string string/f )
     ":" split1 ;
 
+: copy-message-in ( origin dest -- )
+    { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
+      [ [ line>>       ] dip (>>line) ]
+      [ [ prefix>>     ] dip (>>prefix) ]
+      [ [ command>>    ] dip (>>command) ]
+      [ [ trailing>>   ] dip (>>trailing) ]
+      [ [ timestamp>>  ] dip (>>timestamp) ]
+    } 2cleave ;
+
 PRIVATE>
 
 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
@@ -124,7 +148,4 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
         { "MODE"    [ mode ] }
         { "KICK"    [ kick ] }
         [ drop unhandled ]
-    } case
+    } case new [ copy-message-in ] keep ;
-    [ [ tuple-slots ] [ parameters>> ] bi append ] dip
-    [ all-slots over [ length ] bi@ min head >quotation ] keep
-    '[ @ _ boa ] call ;

extra/printf/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/printf/printf-docs.factor

@@ -0,0 +1,74 @@
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: printf
+
+HELP: printf
+{ $values { "format-string" string } }
+{ $description "Writes the arguments (specified on the stack) formatted according to the format string." } 
+{ $examples 
+    { $example
+        "USING: printf ;"
+        "123 \"%05d\" printf"
+        "00123" }
+    { $example
+        "USING: printf ;"
+        "HEX: ff \"%04X\" printf"
+        "00FF" }
+    { $example
+        "USING: printf ;"
+        "1.23456789 \"%.3f\" printf"
+        "1.234" }
+    { $example 
+        "USING: printf ;"
+        "1234567890 \"%.5e\" printf"
+        "1.23456e+09" }
+    { $example
+        "USING: printf ;"
+        "12 \"%'#4d\" printf"
+        "##12" }
+    { $example
+        "USING: printf ;"
+        "1234 \"%+d\" printf"
+        "+1234" }
+} ;
+
+HELP: sprintf
+{ $values { "format-string" string } { "result" string } }
+{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } 
+{ $see-also printf } ;
+
+ARTICLE: "printf" "Formatted printing"
+"The " { $vocab-link "printf" } " and " { $vocab-link "sprintf" } " words are used for formatted printing.\n"
+"\n"
+"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
+{ $table
+    { "%%"    "Single %" "" }
+    { "%P.Ds" "String format" "string" }
+    { "%P.DS" "String format uppercase" "string" }
+    { "%c"    "Character format" "char" } 
+    { "%C"    "Character format uppercase" "char" } 
+    { "%+Pd"   "Integer format"  "fixnum" }
+    { "%+P.De" "Scientific notation" "fixnum, float" }
+    { "%+P.DE" "Scientific notation" "fixnum, float" }
+    { "%+P.Df" "Fixed format" "fixnum, float" }
+    { "%+Px"   "Hexadecimal" "hex" }
+    { "%+PX"   "Hexadecimal uppercase" "hex" }
+}
+"\n"
+"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n"
+"\n"
+"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment.  By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n"
+{ $list
+    "\"%5s\" formats a string padding with spaces up to 5 characters wide."
+    "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
+    "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
+    "\"%-10d\" formats an integer to 10 characters wide and left-aligns." 
+}
+"\n"
+"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n"
+{ $list 
+    "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
+    "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+    "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
+} ;

extra/printf/printf-tests.factor

@@ -0,0 +1,126 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel printf tools.test ;
+
+[ "%s" printf ] must-infer 
+
+[ "%s" sprintf ] must-infer
+
+[ t ] [ "10" 10 "%d" sprintf = ] unit-test
+
+[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
+
+[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
+
+[ t ] [ "  -10" -10 "%5d" sprintf = ] unit-test
+
+[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
+
+[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
+
+[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test
+
+[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
+
+[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test
+
+[ t ] [ "  1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
+
+[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test
+
+[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test
+
+[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
+
+[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
+
+[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test
+
+[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test
+
+[ t ] [ "   1.0E+01" 10 "%10.1E" sprintf = ] unit-test
+
+[ t ] [ "  -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
+
+[ t ] [ "  -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
+
+[ t ] [ "  +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
+
+[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
+
+[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
+
+[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
+
+[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
+
+[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
+
+[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
+
+[ t ] [ "2008-09-10" 
+        2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
+
+[ t ] [ "Hello, World!" 
+        "Hello, World!" "%s" sprintf = ] unit-test
+
+[ t ] [ "printf test" 
+        "printf test" sprintf = ] unit-test
+
+[ t ] [ "char a = 'a'"
+        CHAR: a "char %c = 'a'" sprintf = ] unit-test
+
+[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
+
+[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
+
+[ t ] [ "0 message(s)"
+        0 "message" "%d %s(s)" sprintf = ] unit-test
+
+[ t ] [ "0 message(s) with %"
+        0 "message" "%d %s(s) with %%" sprintf = ] unit-test
+
+[ t ] [ "justif: \"left      \""
+        "left" "justif: \"%-10s\"" sprintf = ] unit-test
+
+[ t ] [ "justif: \"     right\""
+        "right" "justif: \"%10s\"" sprintf = ] unit-test
+
+[ t ] [ " 3: 0003 zero padded" 
+        3 " 3: %04d zero padded" sprintf = ] unit-test
+
+[ t ] [ " 3: 3    left justif" 
+        3 " 3: %-4d left justif" sprintf = ] unit-test
+
+[ t ] [ " 3:    3 right justif" 
+        3 " 3: %4d right justif" sprintf = ] unit-test
+
+[ t ] [ " -3: -003 zero padded"
+        -3 " -3: %04d zero padded" sprintf = ] unit-test
+
+[ t ] [ " -3: -3   left justif"
+        -3 " -3: %-4d left justif" sprintf = ] unit-test
+
+[ t ] [ " -3:   -3 right justif"
+        -3 " -3: %4d right justif" sprintf = ] unit-test
+
+[ t ] [ "There are 10 monkeys in the kitchen" 
+        10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
+
+[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
+
+[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
+
+[ t ] [ "[    monkey]" "monkey" "[%10s]" sprintf = ] unit-test
+
+[ t ] [ "[monkey    ]" "monkey" "[%-10s]" sprintf = ] unit-test
+
+[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
+
+[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
+
+[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+
+
+

extra/printf/printf.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: io io.encodings.ascii io.files io.streams.string combinators
+kernel sequences splitting strings math math.parser macros
+fry peg.ebnf ascii unicode.case arrays quotations vectors ;
+
+IN: printf
+
+<PRIVATE
+
+: compose-all ( seq -- quot )
+    [ ] [ compose ] reduce ;
+
+: fix-sign ( string -- string )
+    dup CHAR: 0 swap index 0 = 
+      [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
+         [ dup 1- rot dup [ nth ] dip swap
+            {
+               { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
+               { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+               [ drop swap drop ] 
+            } case 
+         ] [ drop ] if
+      ] when ;
+
+: >digits ( string -- digits ) 
+    [ 0 ] [ string>number ] if-empty ;
+
+: max-digits ( string digits -- string ) 
+    [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ;
+
+: max-width ( string length -- string ) 
+    short head ;
+
+: >exponential ( n -- base exp ) 
+    [ 0 < ] keep abs 0 
+    [ swap dup [ 10.0 >= ] keep 1.0 < or ] 
+    [ dup 10.0 >= 
+      [ 10.0 / [ 1+ ] dip swap ] 
+      [ 10.0 * [ 1- ] dip swap ] if
+    ] [ swap ] while 
+    [ number>string ] dip 
+    dup abs number>string 2 CHAR: 0 pad-left
+    [ 0 < "-" "+" ? ] dip append
+    "e" prepend 
+    rot [ [ "-" prepend ] dip ] when ; 
+
+EBNF: parse-format-string
+
+zero      = "0"                  => [[ CHAR: 0 ]]
+char      = "'" (.)              => [[ second ]]
+
+pad-char  = (zero|char)?         => [[ CHAR: \s or 1quotation ]]
+pad-align = ("-")?               => [[ [ pad-right ] [ pad-left ] ? ]] 
+pad-width = ([0-9])*             => [[ >digits 1quotation ]]
+pad       = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]]
+
+sign      = ("+")?               => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]]
+
+width_    = "." ([0-9])*         => [[ second >digits '[ _ max-width ] ]]
+width     = (width_)?            => [[ [ ] or ]] 
+
+digits_   = "." ([0-9])*         => [[ second >digits '[ _ max-digits ] ]]
+digits    = (digits_)?           => [[ [ ] or ]]
+
+fmt-%     = "%"                  => [[ [ "%" ] ]] 
+fmt-c     = "c"                  => [[ [ 1string ] ]]
+fmt-C     = "C"                  => [[ [ 1string >upper ] ]]
+fmt-s     = "s"                  => [[ [ ] ]]
+fmt-S     = "S"                  => [[ [ >upper ] ]]
+fmt-d     = "d"                  => [[ [ >fixnum number>string ] ]]
+fmt-e     = "e"                  => [[ [ >exponential ] ]]
+fmt-E     = "E"                  => [[ [ >exponential >upper ] ]]
+fmt-f     = "f"                  => [[ [ >float number>string ] ]] 
+fmt-x     = "x"                  => [[ [ >hex ] ]]
+fmt-X     = "X"                  => [[ [ >hex >upper ] ]]
+unknown   = (.)*                 => [[ "Unknown directive" throw ]]
+
+chars     = fmt-c | fmt-C
+strings   = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]]
+decimals  = fmt-d
+exps      = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] 
+floats    = digits fmt-f         => [[ reverse compose-all ]]
+hex       = fmt-x | fmt-X
+numbers   = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]]
+
+formats   = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+           => [[ >string '[ _ swap ] ]]
+
+text      = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: printf ( format-string -- )
+    parse-format-string [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
+
+: sprintf ( format-string -- result )
+    [ printf ] with-string-writer ; inline
+
+

extra/printf/summary.txt

@@ -0,0 +1 @@
+Format data according to a specified format string, and writes (or returns) the result string.  

extra/webapps/wiki/initial-content/Wiki Help.txt

@@ -1,5 +1,5 @@
 This Wiki uses [[Farkup]] to mark up text.
 
-Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
+Two special article names are recognized by the Wiki: [[Contents]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
 
 The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].

extra/webapps/wiki/view.xml

@@ -5,7 +5,7 @@
 	<t:title><t:label t:name="title" /></t:title>
 
 	<div class="description">
-		<t:html t:name="html" />
+		<t:farkup t:name="parsed" t:parsed="true" />
 	</div>
 
 	<p>

extra/webapps/wiki/wiki-common.xml

@@ -10,17 +10,17 @@
 
 	<table width="100%">
 		<tr>
-			<t:if t:value="sidebar">
+			<t:if t:value="contents">
 				<td valign="top" style="width: 210px;">
-					<div class="sidebar">
+					<div class="contents">
-						<t:bind t:name="sidebar">
+						<t:bind t:name="contents">
 							<h2>
 								<t:a t:href="$wiki/view" t:query="title">
 									<t:label t:name="title" />
 								</t:a>
 							</h2>
 
-							<t:html t:name="html" />
+							<t:farkup t:name="parsed" t:parsed="true" />
 						</t:bind>
 					</div>
 				</td>
@@ -59,7 +59,7 @@
 				<td colspan="2">
 					<t:bind t:name="footer">
 						<small>
-							<t:html t:name="html" />
+							<t:farkup t:name="parsed" t:parsed="true" />
 						</small>
 					</t:bind>
 				</td>

extra/webapps/wiki/wiki.css

@@ -38,7 +38,7 @@
     border-width: 1px 1px 0 0;
 }
 
-.sidebar {
+.contents {
     padding: 4px;
     margin: 4px;
     border: 1px dashed grey;

extra/webapps/wiki/wiki.factor

@@ -47,7 +47,7 @@ article "ARTICLES" {
 
 : <article> ( title -- article ) article new swap >>title ;
 
-TUPLE: revision id title author date content html description ;
+TUPLE: revision id title author date content parsed description ;
 
 revision "REVISIONS" {
     { "id" "ID" INTEGER +db-assigned-id+ }
@@ -55,7 +55,7 @@ revision "REVISIONS" {
     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
     { "date" "DATE" TIMESTAMP +not-null+ }
     { "content" "CONTENT" TEXT +not-null+ }
-    { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
+    { "parsed" "PARSED" FACTOR-BLOB +not-null+ } ! Farkup AST
     { "description" "DESCRIPTION" TEXT }
 } define-persistent
 
@@ -73,7 +73,7 @@ M: revision feed-entry-url id>> revision-url ;
     revision new swap >>id ;
 
 : compute-html ( revision -- )
-    dup content>> convert-farkup >>html drop ;
+    dup content>> parse-farkup >>parsed drop ;
 
 : validate-title ( -- )
     { { "title" [ v-one-line ] } } validate-params ;
@@ -344,10 +344,13 @@ M: revision feed-entry-url id>> revision-url ;
         [ "author" value user-edits-url ] >>url
         [ list-user-edits ] >>entries ;
 
-: init-sidebar ( -- )
+: init-sidebars ( -- )
-    "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
+    "Contents" latest-revision [ "contents" [ from-object ] nest-form ] when*
     "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
 
+: init-relative-link-prefix ( -- )
+    URL" $wiki/view/" adjust-url present relative-link-prefix set ;
+
 : <wiki> ( -- dispatcher )
     wiki new-dispatcher
         <main-article-action> "" add-responder
@@ -367,7 +370,7 @@ M: revision feed-entry-url id>> revision-url ;
         <list-changes-feed-action> "changes.atom" add-responder
         <delete-action> "delete" add-responder
     <boilerplate>
-        [ init-sidebar ] >>init
+        [ init-sidebars init-relative-link-prefix ] >>init
         { wiki "wiki-common" } >>template ;
 
 : init-wiki ( -- )

misc/factor.el

@@ -111,6 +111,7 @@
   (use-local-map factor-mode-map)
   (setq major-mode 'factor-mode)
   (setq mode-name "Factor")
+  (set (make-local-variable 'indent-line-function) #'factor-indent-line)
   (make-local-variable 'comment-start)
   (setq comment-start "! ")
   (make-local-variable 'font-lock-defaults)
@@ -224,6 +225,73 @@
 (define-key factor-mode-map "\C-c\C-h" 'factor-help)
 (define-key factor-mode-map "\C-cc"    'comment-region)
 (define-key factor-mode-map [return]   'newline-and-indent)
+(define-key factor-mode-map [tab]      'indent-for-tab-command)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; indentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst factor-word-starting-keywords
+  '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
+
+(defmacro factor-word-start-re (keywords)
+  `(format
+    "^\\(%s\\): "
+    (mapconcat 'identity ,keywords "\\|")))
+
+(defun factor-calculate-indentation ()
+  "Calculate Factor indentation for line at point."
+  (let ((not-indented t)
+        (cur-indent 0))
+    (save-excursion
+      (beginning-of-line)
+      (if (bobp)
+          (setq cur-indent 0)
+        (save-excursion
+          (while not-indented
+            ;; Check that we are inside open brackets
+            (save-excursion
+              (let ((cur-depth (factor-brackets-depth)))
+                (forward-line -1)
+                (setq cur-indent (+ (current-indentation)
+                                    (* default-tab-width
+                                       (- cur-depth (factor-brackets-depth)))))
+                (setq not-indented nil)))
+            (forward-line -1)
+              ;; Check that we are after the end of previous word
+              (if (looking-at ".*;[ \t]*$")
+                  (progn
+                    (setq cur-indent (- (current-indentation) default-tab-width))
+                    (setq not-indented nil))
+                ;; Check that we are after the start of word
+                (if (looking-at (factor-word-start-re factor-word-starting-keywords))
+;                (if (looking-at "^[A-Z:]*: ")
+                    (progn
+                      (message "inword")
+                      (setq cur-indent (+ (current-indentation) default-tab-width))
+                      (setq not-indented nil))
+                  (if (bobp)
+                      (setq not-indented nil))))))))
+    cur-indent))
+
+(defun factor-brackets-depth ()
+  "Returns number of brackets, not closed on previous lines."
+  (syntax-ppss-depth
+   (save-excursion
+     (syntax-ppss (line-beginning-position)))))
+
+(defun factor-indent-line ()
+  "Indent current line as Factor code"
+  (let ((target (factor-calculate-indentation))
+        (pos (- (point-max) (point))))
+    (if (= target (current-indentation))
+        (if (< (current-column) (current-indentation))
+            (back-to-indentation))
+      (beginning-of-line)
+      (delete-horizontal-space)
+      (indent-to target)
+      (if (> (- (point-max) pos) (point))
+          (goto-char (- (point-max) pos))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; factor-listener-mode
@@ -244,5 +312,3 @@
 (defun factor-refresh-all ()
   (interactive)
   (comint-send-string "*factor*" "refresh-all\n"))
-
-

misc/factor.vim

@@ -131,18 +131,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
 
 "adapted from lisp.vim
 if exists("g:factor_norainbow") 
-    syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+    syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
 else
-    syn region factorQuotation0           matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+    syn region factorQuotation0           matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
-    syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+    syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
-    syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+    syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
-    syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+    syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
-    syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+    syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
-    syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+    syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
-    syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+    syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
-    syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+    syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
-    syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+    syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
-    syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+    syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
 endif
 
 if exists("g:factor_norainbow")