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

basis/farkup/farkup-docs.factor

@@ -9,7 +9,7 @@ HELP: write-farkup
 { $values { "string" string } }
 { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
 
-HELP: farkup ( string -- farkup )
+HELP: parse-farkup ( string -- farkup )
 { $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
 { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
 
@@ -18,7 +18,7 @@ HELP: (write-farkup)
 { $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
 
 ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
-"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
 { $subsection heading1 }
 { $subsection heading2 }
 { $subsection heading3 }
@@ -44,7 +44,7 @@ $nl
 { $subsection convert-farkup }
 { $subsection write-farkup }
 "The syntax tree of a piece of Farkup can also be inspected and modified:"
-{ $subsection farkup }
+{ $subsection parse-farkup }
 { $subsection (write-farkup) }
 { $subsection "farkup-ast" } ;
 

basis/farkup/farkup-tests.factor

@@ -11,13 +11,11 @@ link-no-follow? off
 [ "Baz" ] [ "Baz" simple-link-title ] unit-test
 
 [ ] [
-    "abcd-*strong*\nasdifj\nweouh23ouh23"
+    "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
-    "paragraph" \ farkup rule parse drop
 ] unit-test
 
 [ ] [
-    "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+    "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
-    "paragraph" \ farkup rule parse drop
 ] unit-test
 
 [ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
@@ -118,3 +116,7 @@ link-no-follow? off
 ] unit-test
 
 [ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+
+[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+
+[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test

basis/farkup/farkup.factor

@@ -1,29 +1,29 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators html.elements io io.streams.string
+USING: accessors arrays combinators html.elements io
-kernel math memoize namespaces peg peg.ebnf prettyprint
+io.streams.string kernel math memoize namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities vectors splitting
+prettyprint sequences sequences.deep strings xml.entities
-xmode.code2html ;
+vectors splitting xmode.code2html urls ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?
 
-TUPLE: heading1 obj ;
+TUPLE: heading1 child ;
-TUPLE: heading2 obj ;
+TUPLE: heading2 child ;
-TUPLE: heading3 obj ;
+TUPLE: heading3 child ;
-TUPLE: heading4 obj ;
+TUPLE: heading4 child ;
-TUPLE: strong obj ;
+TUPLE: strong child ;
-TUPLE: emphasis obj ;
+TUPLE: emphasis child ;
-TUPLE: superscript obj ;
+TUPLE: superscript child ;
-TUPLE: subscript obj ;
+TUPLE: subscript child ;
-TUPLE: inline-code obj ;
+TUPLE: inline-code child ;
-TUPLE: paragraph obj ;
+TUPLE: paragraph child ;
-TUPLE: list-item obj ;
+TUPLE: list-item child ;
-TUPLE: list obj ;
+TUPLE: list child ;
-TUPLE: table obj ;
+TUPLE: table child ;
-TUPLE: table-row obj ;
+TUPLE: table-row child ;
 TUPLE: link href text ;
 TUPLE: image href text ;
 TUPLE: code mode string ;
@@ -34,7 +34,7 @@ TUPLE: code mode string ;
 : simple-link-title ( string -- string' )
     dup absolute-url? [ "/" last-split1 swap or ] unless ;
 
-EBNF: farkup
+EBNF: parse-farkup
 nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
 2nl              = nl nl
 
@@ -65,7 +65,7 @@ subscript     = "~" (!("~" | nl).)+ "~"
 inline-code   = "%" (!("%" | nl).)+ "%"
     => [[ second >string inline-code boa ]]
 
-escaped-char  = "\" .                => [[ second ]]
+escaped-char  = "\" .                => [[ second 1string ]]
 
 link-content     = (!("|"|"]").)+
 
@@ -89,20 +89,26 @@ inline-tag       = strong | emphasis | superscript | subscript | inline-code
 
 inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
 
-table-column     = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter  ) '|'
+cell             = (!(inline-delimiter | '|' | nl).)+
+    => [[ >string ]]
+    
+table-column     = (list | cell | inline-tag | inline-delimiter  ) '|'
     => [[ first ]]
 table-row        = "|" (table-column)+
     => [[ second table-row boa ]]
 table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
     => [[ table boa ]]
 
-paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+text = (!(nl | code | heading | inline-delimiter | table ).)+
+    => [[ >string ]]
+
+paragraph-item = (table | text | inline-tag | inline-delimiter)+
 paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
              | (paragraph-item nl)+ paragraph-item?
              | paragraph-item)
     => [[ paragraph boa ]]
-                
+
-list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+list-item      = '-' (cell | inline-tag)*
     => [[ second list-item boa ]]
 list = ((list-item nl)+ list-item? | list-item)
     => [[ list boa ]]
@@ -136,7 +142,7 @@ stand-alone
 
 : write-link ( href text -- )
     escape-link
-    [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
+    [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
     [ write </a> ]
     bi* ;
 
@@ -146,7 +152,7 @@ stand-alone
         <strong> "Images are not allowed" write </strong>
     ] [
         escape-link
-        [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
+        [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
     ] if ;
 
 : render-code ( string mode -- string' )
@@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- )
 : <foo.> ( string -- ) <foo> write ;
 : </foo.> ( string -- ) </foo> write ;
 : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
+M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
+M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
+M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
+M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
+M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
+M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
+M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
+M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
+M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
+M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
-M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
+M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
-M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
+M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
-M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
+M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
-M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
-M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
 M: table-row (write-farkup) ( obj -- )
-    obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
+    child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
+M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
-M: fixnum (write-farkup) ( obj -- ) write1 ;
+M: string (write-farkup) escape-string write ;
-M: string (write-farkup) ( obj -- ) write ;
+M: vector (write-farkup) [ (write-farkup) ] each ;
-M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
+M: f (write-farkup) drop ;
-M: f (write-farkup) ( obj -- ) drop ;
 
 : write-farkup ( string -- )
-    farkup (write-farkup) ;
+    parse-farkup (write-farkup) ;
 
 : convert-farkup ( string -- string' )
-    farkup [ (write-farkup) ] with-string-writer ;
+    parse-farkup [ (write-farkup) ] with-string-writer ;

basis/furnace/actions/actions.factor

@@ -14,7 +14,8 @@ html.elements
 html.components
 html.components
 html.templates.chloe
-html.templates.chloe.syntax ;
+html.templates.chloe.syntax
+html.templates.chloe.compiler ;
 IN: furnace.actions
 
 SYMBOL: params
@@ -29,7 +30,8 @@ SYMBOL: rest
         </ul>
     ] unless-empty ;
 
-CHLOE: validation-messages drop render-validation-messages ;
+CHLOE: validation-messages
+    drop [ render-validation-messages ] [code] ;
 
 TUPLE: action rest authorize init display validate submit ;
 

basis/html/elements/elements.factor

@@ -48,8 +48,6 @@ IN: html.elements
 !
 ! <input "text" =type "name" =name "20" =size input/>
 
-: elements-vocab ( -- vocab-name ) "html.elements" ;
-
 SYMBOL: html
 
 : write-html ( str -- )
@@ -60,6 +58,8 @@ SYMBOL: html
 
 <<
 
+: elements-vocab ( -- vocab-name ) "html.elements" ;
+
 : html-word ( name def effect -- )
     #! Define 'word creating' word to allow
     #! dynamically creating words.

basis/urls/urls.factor

@@ -14,7 +14,7 @@ IN: urls
         [ letter? ]
         [ LETTER? ]
         [ digit? ]
-        [ "/_-." member? ]
+        [ "/_-.:" member? ]
     } 1|| ; foldable
 
 <PRIVATE
@@ -25,7 +25,7 @@ IN: urls
 
 PRIVATE>
 
-: url-encode ( str -- str )
+: url-encode ( str -- encoded )
     [
         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
     ] "" make ;
@@ -58,7 +58,7 @@ PRIVATE>
 
 PRIVATE>
 
-: url-decode ( str -- str )
+: url-decode ( str -- decoded )
     [ 0 swap url-decode-iter ] "" make utf8 decode ;
 
 <PRIVATE

core/memory/memory-tests.factor

@@ -1,4 +1,4 @@
-USING: generic kernel kernel.private math memory prettyprint
+USING: generic kernel kernel.private math memory prettyprint io
 sequences tools.test words namespaces layouts classes
 classes.builtin arrays quotations ;
 IN: memory.tests
@@ -19,6 +19,7 @@ TUPLE: testing x y z ;
 [ ] [
     num-types get [
         type>class [
+            dup . flush
             "predicate" word-prop instances [
                 class drop
             ] each

core/sequences/sequences-docs.factor

@@ -1356,16 +1356,18 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 "A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
 { $subsection slice }
 { $subsection slice? }
-"Creating slices:"
+"Extracting a slice:"
 { $subsection <slice> }
 { $subsection head-slice }
 { $subsection tail-slice }
-{ $subsection but-last-slice }
-{ $subsection rest-slice }
 { $subsection head-slice* }
 { $subsection tail-slice* }
+"Removing the first or last element:"
+{ $subsection rest-slice }
+{ $subsection but-last-slice }
 "Taking a sequence apart into a head and a tail:"
 { $subsection unclip-slice }
+{ $subsection unclip-last-slice }
 { $subsection cut-slice }
 "A utility for words which use slices as iterators:"
 { $subsection <flat-slice> } ;

extra/irc/client/client.factor

@@ -91,8 +91,6 @@ SYMBOL: current-irc-client
 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
 
-: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
-    [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
 
 GENERIC: to-listener ( message obj -- )
 
@@ -294,14 +292,14 @@ DEFER: (connect-irc)
     [ (reader-loop) ] [ handle-disconnect ] recover t ;
 
 : writer-loop ( -- ? )
-    irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
+    irc> out-messages>> mailbox-get handle-outgoing-irc t ;
 
 ! ======================================
 ! Processing loops
 ! ======================================
 
 : in-multiplexer-loop ( -- ? )
-    irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
+    irc> in-messages>> mailbox-get handle-incoming-irc t ;
 
 : strings>privmsg ( name string -- privmsg )
     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@@ -314,9 +312,10 @@ DEFER: (connect-irc)
 
 : listener-loop ( name -- ? )
     dup listener> [
-        out-messages>> [ maybe-annotate-with-name
+        out-messages>> mailbox-get
-                         irc> out-messages>> mailbox-put ] with
+        maybe-annotate-with-name
-        maybe-mailbox-get t
+        irc> out-messages>> mailbox-put
+        t
     ] [ drop f ] if* ;
 
 : spawn-irc-loop ( quot: ( -- ? ) name -- )

extra/webapps/counter/counter.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel accessors http.server http.server.dispatchers
 furnace furnace.actions furnace.sessions furnace.redirection
 html.components html.forms html.templates.chloe
@@ -28,3 +30,20 @@ M: counter-app init-session* drop 0 count sset ;
         [ 1- ] <counter-action> "dec" add-responder
         <display-action> "" add-responder
     <sessions> ;
+
+! Deployment example
+USING: db.sqlite db.tuples db furnace.db namespaces ;
+
+: counter-db ( -- params db ) "counter.db" sqlite-db ;
+
+: init-counter-db ( -- )
+    counter-db [ session ensure-table ] with-db ;
+
+: run-counter ( -- )
+    init-counter-db
+    <counter-app>
+        counter-db <db-persistence>
+        main-responder set-global
+    8080 httpd ;
+
+MAIN: run-counter

unfinished/regexp/dfa/dfa.factor

@@ -27,7 +27,6 @@ IN: regexp.dfa
     nfa-table>> transitions>>
     [ at keys ] curry map concat
     eps swap remove ;
-    ! dup t member? [ t swap remove t suffix ] when ;
 
 : add-todo-state ( state regexp -- )
     2dup visited-states>> key? [

unfinished/regexp/regexp.factor

@@ -33,7 +33,19 @@ IN: regexp
     dupd match
     [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
 
-: match-head ( string regexp -- end ) match length>> 1- ;
+: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ;
+
+: match-at ( string m regexp -- n/f finished? )
+    [
+        2dup swap length > [ 2drop f f ] [ tail-slice t ] if
+    ] dip swap [ match-head f ] [ 2drop f t ] if ;
+
+: match-range ( string m regexp -- a/f b/f )
+    3dup match-at over [
+        drop nip rot drop dupd +
+    ] [
+        [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
+    ] if ;
 
 : initial-option ( regexp option -- regexp' )
     over options>> conjoin ;

unfinished/regexp/transition-tables/transition-tables.factor

@@ -32,7 +32,12 @@ TUPLE: transition-table transitions start-state final-states ;
         H{ } clone >>transitions
         H{ } clone >>final-states ;
 
+: maybe-initialize-key ( key hashtable -- )
+    2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
+
 : set-transition ( transition hash -- )
+    #! set the state as a key
+    2dup [ to>> ] dip maybe-initialize-key
     [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
     2dup at* [ 2nip insert-at ]
     [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;

unfinished/regexp/traversal/traversal.factor

@@ -43,6 +43,10 @@ TUPLE: dfa-traverser
         dup save-final-state
     ] when text-finished? ;
 
+: print-flags ( dfa-traverser -- dfa-traverser )
+    dup [ current-state>> ] [ traversal-flags>> ] bi
+    ;
+
 : increment-state ( dfa-traverser state -- dfa-traverser )
     [
         [ 1+ ] change-current-index dup current-state>> >>last-state

vm/image.c

@@ -186,13 +186,16 @@ void strip_compiled_quotations(void)
 
 DEFINE_PRIMITIVE(save_image_and_exit)
 {
-	/* This reduces deployed image size */
+	/* We unbox this before doing anything else. This is the only point
-	strip_compiled_quotations();
+	where we might throw an error, so we have to throw an error here since
-
+	later steps destroy the current image. */
 	F_CHAR *path = unbox_native_string();
 
 	REGISTER_C_STRING(path);
 
+	/* This reduces deployed image size */
+	strip_compiled_quotations();
+
 	/* strip out userenv data which is set on startup anyway */
 	CELL i;
 	for(i = 0; i < FIRST_SAVE_ENV; i++)