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

core/compiler/tests/stack-trace.factor

@@ -30,10 +30,3 @@ words splitting grouping sorting ;
     \ + stack-trace-contains?
     \ > stack-trace-contains?
 ] unit-test
-
-: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
-
-[ t ] [
-    [ 10 quux ] ignore-errors
-    \ sort stack-trace-contains?
-] unit-test

core/optimizer/optimizer-tests.factor

@@ -219,7 +219,7 @@ M: number detect-number ;
 
 ! Regression
 USE: sorting
-USE: sorting.private
+USE: binary-search.private
 
 : old-binsearch ( elt quot seq -- elt quot i )
     dup length 1 <= [
@@ -227,7 +227,7 @@ USE: sorting.private
     ] [
         [ midpoint swap call ] 3keep roll dup zero?
         [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
+        [ dup midpoint@ cut-slice old-binsearch ] if
     ] if ; inline
 
 [ 10 ] [

core/sorting/sorting-docs.factor

@@ -3,6 +3,10 @@ sequences math.order ;
 IN: sorting
 
 ARTICLE: "sequences-sorting" "Sorting sequences"
+"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
+$nl
+"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
+$nl
 "Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
 $nl
 "Sorting a sequence with a custom comparator:"

core/sorting/sorting-tests.factor

@@ -18,3 +18,9 @@ unit-test
 ] unit-test
 
 [ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
+
+! Is it a stable sort?
+[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test
+
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test

core/sorting/sorting.factor

@@ -50,13 +50,13 @@ TUPLE: merge
 : dump-r  [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
 : l-next  [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
 : r-next  [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
-: decide  [ [ l-elt ] [ r-elt ] bi ] dip call +lt+ eq? ; inline
+: decide  [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
 
 : (merge) ( merge quot -- )
-    over l-done? [ drop dump-r ] [
     over r-done? [ drop dump-l ] [
+        over l-done? [ drop dump-r ] [
             2dup decide
-            [ over l-next ] [ over r-next ] if
+            [ over r-next ] [ over l-next ] if
             (merge)
         ] if
     ] if ; inline

extra/benchmark/backtrack/backtrack.factor

@@ -0,0 +1,65 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: backtrack shuffle math math.ranges quotations locals fry
+kernel words io memoize macros io prettyprint sequences assocs
+combinators namespaces ;
+IN: benchmark.backtrack
+
+! This was suggested by Dr_Ford. Compute the number of quadruples
+! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
+! placing them on the stack, and applying the operations
+! +, -, * and rot as many times as we wish.
+
+: nop ;
+
+MACRO: amb-execute ( seq -- quot )
+    [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
+    '[ , amb , case ] ;
+
+: if-amb ( true false -- )
+    [
+        [ { t f } amb ]
+        [ '[ @ require t ] ]
+        [ '[ @ f ] ]
+        tri* if
+    ] with-scope ; inline
+
+: do-something ( a b -- c )
+    { + - * } amb-execute ;
+
+: some-rots ( a b c -- a b c )
+    #! Try to rot 0, 1 or 2 times.
+    { nop rot -rot } amb-execute ;
+
+MEMO: 24-from-1 ( a -- ? )
+    24 = ;
+
+MEMO: 24-from-2 ( a b -- ? )
+    [ do-something 24-from-1 ] [ 2drop ] if-amb ;
+
+MEMO: 24-from-3 ( a b c -- ? )
+    [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
+
+MEMO: 24-from-4 ( a b c d -- ? )
+    [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
+
+: find-impossible-24 ( -- n )
+    1 10 [a,b] [| a |
+        1 10 [a,b] [| b |
+            1 10 [a,b] [| c |
+                1 10 [a,b] [| d |
+                    a b c d 24-from-4
+                ] count
+            ] sigma
+        ] sigma
+    ] sigma ;
+
+: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
+
+: backtrack-benchmark ( -- )
+    words [ reset-memoized ] each
+    find-impossible-24 pprint "/10000 quadruples can make 24." print
+    words [
+        dup pprint " tested " write "memoize" word-prop assoc-size pprint
+        " possibilities" print
+    ] each ;

extra/channels/channels-tests.factor

@@ -17,7 +17,7 @@ IN: channels.tests
     from 
 ] unit-test
 
-{ V{ 1 2 3 4 } } [
+{ { 1 2 3 4 } } [
     V{ } clone <channel>
     [ from swap push ] in-thread
     [ from swap push ] in-thread
@@ -30,7 +30,7 @@ IN: channels.tests
     natural-sort
 ] unit-test
 
-{ V{ 1 2 4 9 } } [
+{ { 1 2 4 9 } } [
     V{ } clone <channel>
     [ 4 swap to ] in-thread
     [ 2 swap to ] in-thread

extra/farkup/authors.factor

@@ -1,2 +0,0 @@
-Doug Coleman
-Slava Pestov

extra/farkup/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Slava Pestov

extra/farkup/farkup-tests.factor

@@ -1,12 +1,19 @@
-USING: farkup kernel tools.test ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: farkup kernel peg peg.ebnf tools.test ;
 IN: farkup.tests
 
-[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
+[ ] [
-[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
+    "abcd-*strong*\nasdifj\nweouh23ouh23"
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
+    "paragraph" \ farkup rule parse drop
-[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+] unit-test
 
-[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ ] [
+    "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+    "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
 [ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
 [ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
 [ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
@@ -15,11 +22,20 @@ IN: farkup.tests
 [ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
 [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
 
-[ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
-[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
-[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
-[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
-[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+
+
+[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
@@ -29,7 +45,7 @@ IN: farkup.tests
 [ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
 [ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
 
-[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
 
 [ "" ] [ "" convert-farkup ] unit-test
 
@@ -77,8 +93,5 @@ IN: farkup.tests
 ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
 
 [
-    "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+    "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
 ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
-
-[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
-[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

extra/farkup/farkup.factor

@@ -1,72 +1,111 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg math
+USING: accessors arrays combinators html.elements io io.streams.string
-combinators sequences strings html.elements xml.entities
+kernel math memoize namespaces peg peg.ebnf prettyprint
-xmode.code2html splitting io.streams.string peg.parsers
+sequences sequences.deep strings xml.entities vectors splitting
-sequences.deep unicode.categories ;
+xmode.code2html ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?
 
-<PRIVATE
+TUPLE: heading1 obj ;
+TUPLE: heading2 obj ;
+TUPLE: heading3 obj ;
+TUPLE: heading4 obj ;
+TUPLE: strong obj ;
+TUPLE: emphasis obj ;
+TUPLE: superscript obj ;
+TUPLE: subscript obj ;
+TUPLE: inline-code obj ;
+TUPLE: paragraph obj ;
+TUPLE: list-item obj ;
+TUPLE: list obj ;
+TUPLE: table obj ;
+TUPLE: table-row obj ;
+TUPLE: link href text ;
+TUPLE: image href text ;
+TUPLE: code mode string ;
 
-: delimiters ( -- string )
+EBNF: farkup
-    "*_^~%[-=|\\\r\n" ; inline
+nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+2nl              = nl nl
 
-MEMO: text ( -- parser )
+heading1      = "=" (!("=" | nl).)+ "="
-    [ delimiters member? not ] satisfy repeat1
+    => [[ second >string heading1 boa ]]
-    [ >string escape-string ] action ;
 
-MEMO: delimiter ( -- parser )
+heading2      = "==" (!("=" | nl).)+ "=="
-    [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
+    => [[ second >string heading2 boa ]]
-    [ 1string ] action ;
 
-: surround-with-foo ( string tag -- seq )
+heading3      = "===" (!("=" | nl).)+ "==="
-    dup <foo> swap </foo> swapd 3array ;
+    => [[ second >string heading3 boa ]]
 
-: delimited ( str html -- parser )
+heading4      = "====" (!("=" | nl).)+ "===="
-    [
+    => [[ second >string heading4 boa ]]
-        over token hide ,
-        text [ surround-with-foo ] swapd curry action ,
-        token hide ,
-    ] seq* ;
 
-MEMO: escaped-char ( -- parser )
+strong        = "*" (!("*" | nl).)+ "*"
-    [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+    => [[ second >string strong boa ]]
 
-MEMO: strong ( -- parser ) "*" "strong" delimited ;
+emphasis      = "_" (!("_" | nl).)+ "_"
-MEMO: emphasis ( -- parser ) "_" "em" delimited ;
+    => [[ second >string emphasis boa ]]
-MEMO: superscript ( -- parser ) "^" "sup" delimited ;
+
-MEMO: subscript ( -- parser ) "~" "sub" delimited ;
+superscript   = "^" (!("^" | nl).)+ "^"
-MEMO: inline-code ( -- parser ) "%" "code" delimited ;
+    => [[ second >string superscript boa ]]
-MEMO: nl ( -- parser )
+
-    "\r\n" token [ drop "\n" ] action
+subscript     = "~" (!("~" | nl).)+ "~"
-    "\r" token [ drop "\n" ] action
+    => [[ second >string subscript boa ]]
-    "\n" token 3choice ;
+
-MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
+inline-code   = "%" (!("%" | nl).)+ "%"
-MEMO: h1 ( -- parser ) "=" "h1" delimited ;
+    => [[ second >string inline-code boa ]]
-MEMO: h2 ( -- parser ) "==" "h2" delimited ;
+
-MEMO: h3 ( -- parser ) "===" "h3" delimited ;
+escaped-char  = "\" .                => [[ second ]]
-MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+
+image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
+                    => [[ [ second >string ] [ fourth >string ] bi image boa ]]
+                  | "[[image:" (!("]").)+ "]]"
+                    => [[ second >string f image boa ]]
+
+simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
+    => [[ second >string dup link boa ]]
+
+labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
+    => [[ [ second >string ] [ fourth >string ] bi link boa ]]
+
+link             = image-link | labelled-link | simple-link
+
+heading          = heading4 | heading3 | heading2 | heading1
+
+inline-tag       = strong | emphasis | superscript | subscript | inline-code
+                   | link | escaped-char
+
+inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
+
+table-column     = (list | (!(nl | inline-delimiter | '|').)+ | 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)+
+paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
+             | (paragraph-item nl)+ paragraph-item?
+             | paragraph-item)
+    => [[ paragraph boa ]]
+                
+list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+    => [[ second list-item boa ]]
+list = ((list-item nl)+ list-item? | list-item)
+    => [[ list boa ]]
+
+code       =  '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+    => [[ [ second >string ] [ fourth >string ] bi code boa ]]
+
+stand-alone      = (code | heading | list | table | paragraph | nl)*
+;EBNF
 
-MEMO: eq ( -- parser )
-    [
-        h1 ensure-not ,
-        h2 ensure-not ,
-        h3 ensure-not ,
-        h4 ensure-not ,
-        "=" token ,
-    ] seq* ;
 
-: render-code ( string mode -- string' )
-    >r string-lines r>
-    [
-        <pre>
-            htmlize-lines
-        </pre>
-    ] with-string-writer ;
 
 : invalid-url "javascript:alert('Invalid URL in farkup');" ;
 
@@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
 : escape-link ( href text -- href-esc text-esc )
     >r check-url escape-quoted-string r> escape-string ;
 
-: make-link ( href text -- seq )
+: write-link ( text href -- )
     escape-link
-    [
+    "<a" write
-        "<a" ,
+    " href=\"" write write "\"" write
-        " href=\"" , >r , r> "\"" ,
+    link-no-follow? get [ " nofollow=\"true\"" write ] when
-        link-no-follow? get [ " nofollow=\"true\"" , ] when
+    ">" write write "</a>" write ;
-        ">" , , "</a>" ,
-    ] { } make ;
 
-: make-image-link ( href alt -- seq )
+: write-image-link ( href text -- )
     disable-images? get [
-        2drop "<strong>Images are not allowed</strong>"
+        2drop "<strong>Images are not allowed</strong>" write
     ] [
         escape-link
-        [
+        >r "<img src=\"" write write "\"" write r>
-            "<img src=\"" , swap , "\"" ,
+        dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
-            dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+        "/>" write
-            "/>" ,
-        ] { } make
     ] if ;
 
-MEMO: image-link ( -- parser )
+: render-code ( string mode -- string' )
+    >r string-lines r>
     [
-        "[[image:" token hide ,
+        <pre>
-        [ "|]" member? not ] satisfy repeat1 [ >string ] action ,
+            htmlize-lines
-        "|" token hide
+        </pre>
-            [ CHAR: ] = not ] satisfy repeat0 2seq
+    ] with-string-writer write ;
-            [ first >string ] action optional ,
-        "]]" token hide ,
-    ] seq* [ first2 make-image-link ] action ;
 
-MEMO: simple-link ( -- parser )
+GENERIC: write-farkup ( obj -- )
-    [
+: <foo.> ( string -- ) <foo> write ;
-        "[[" token hide ,
+: </foo.> ( string -- ) </foo> write ;
-        [ "|]" member? not ] satisfy repeat1 ,
+: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-        "]]" token hide ,
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
-    ] seq* [ first dup make-link ] action ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
-
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
-MEMO: labelled-link ( -- parser )
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
-    [
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
-        "[[" token hide ,
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
-        [ CHAR: | = not ] satisfy repeat1 ,
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
-        "|" token hide ,
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
-        [ CHAR: ] = not ] satisfy repeat1 ,
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
-        "]]" token hide ,
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
-    ] seq* [ first2 make-link ] action ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
-
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
-MEMO: link ( -- parser )
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
-    [ image-link , simple-link , labelled-link , ] choice* ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
-DEFER: line
+M: table-row write-farkup ( obj -- )
-MEMO: list-item ( -- parser )
+    obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
-    [
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
-        "-" token hide , ! text ,
+M: fixnum write-farkup ( obj -- ) write1 ;
-        [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
+M: string write-farkup ( obj -- ) write ;
-    ] seq* [ "li" surround-with-foo ] action ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
-
+M: f write-farkup ( obj -- ) drop ;
-MEMO: list ( -- parser )
-    list-item nl hide list-of
-    [ "ul" surround-with-foo ] action ;
-
-MEMO: table-column ( -- parser )
-    text [ "td" surround-with-foo ] action ;
-
-MEMO: table-row ( -- parser )
-    "|" token hide
-    table-column "|" token hide list-of
-    "|" token hide nl hide optional 4seq
-    [ "tr" surround-with-foo ] action ;
-
-MEMO: table ( -- parser )
-    table-row repeat1
-    [ "table" surround-with-foo ] action ;
-
-MEMO: code ( -- parser )
-    [
-        "[" token hide ,
-        [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
-        "{" token hide ,
-        "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
-        "}]" token hide ,
-    ] seq* [ first2 swap render-code ] action ;
-
-MEMO: line ( -- parser )
-    [
-        nl table 2seq ,
-        nl list 2seq ,
-        text , strong , emphasis , link ,
-        superscript , subscript , inline-code ,
-        escaped-char , delimiter , eq ,
-    ] choice* repeat1 ;
-
-MEMO: paragraph ( -- parser )
-    line
-    nl over 2seq repeat0
-    nl nl ensure-not 2seq optional 3seq
-    [
-        dup [ dup string? not swap [ blank? ] all? or ] deep-all?
-        [ "<p>" swap "</p>" 3array ] unless
-    ] action ;
-
-PRIVATE>
-
-PEG: parse-farkup ( -- parser )
-    [
-        list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat0 nl optional 2seq ;
-
-: write-farkup ( parse-result  -- )
-    [ dup string? [ write ] [ drop ] if ] deep-each ;
 
 : convert-farkup ( string -- string' )
-    parse-farkup [ write-farkup ] with-string-writer ;
+    farkup [ write-farkup ] with-string-writer ;

extra/multi-methods/tests/canonicalize.factor

@@ -49,7 +49,7 @@ kernel strings ;
         { { object ppc object } "b" }
         { { string object windows } "c" }
     }
-    V{ cpu os }
+    { cpu os }
 ] [
     example-1 canonicalize-specializers
 ] unit-test

extra/peg/ebnf/ebnf-tests.factor

@@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
 ] unit-test
 
 [
-  "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
+  "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
 ] must-fail
 
 { t } [

extra/peg/ebnf/ebnf.factor

@@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
 M: ebnf-rule (transform) ( ast -- parser )
   dup elements>> 
   (transform) [
-    swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ 
+    swap symbol>> dup get parser? [ 
       "Rule '" over append "' defined more than once" append throw 
     ] [ 
       set 

extra/ui/gadgets/panes/panes.factor

@@ -1,66 +1,55 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.scrollers
+       ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
+       ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
-ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
+       ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
-hashtables io kernel namespaces sequences io.styles strings
+       hashtables io kernel namespaces sequences io.styles strings
-quotations math opengl combinators math.vectors
+       quotations math opengl combinators math.vectors
-sorting splitting io.streams.nested assocs
+       sorting splitting io.streams.nested assocs
-ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
+       ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines classes.tuple models continuations
+       ui.gadgets.grid-lines classes.tuple models continuations
-destructors accessors math.geometry.rect ;
+       destructors accessors math.geometry.rect ;
+
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack
-output current prototype scrolls?
+       output current prototype scrolls?
-selection-color caret mark selecting? ;
+       selection-color caret mark selecting? ;
 
-: clear-selection ( pane -- )
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-    f >>caret
-    f >>mark
-    drop ;
 
-: add-output ( current pane -- )
+: add-output  ( pane current -- pane ) [ >>output  ] [ add-gadget ] bi ;
-    [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
 
-: add-current ( current pane -- )
+: prepare-line ( pane -- pane )
-    [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
+  clear-selection
+  dup prototype>> clone add-current ;
 
-: prepare-line ( pane -- )
+: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
-    [ clear-selection ]
-    [ [ pane-prototype clone ] keep add-current ] bi ;
-
-: pane-caret&mark ( pane -- caret mark )
-    [ caret>> ] [ mark>> ] bi ;
 
 : selected-children ( pane -- seq )
     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
 
 M: pane gadget-selection? pane-caret&mark and ;
 
-M: pane gadget-selection
+M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
-    selected-children gadget-text ;
 
 : pane-clear ( pane -- )
-    [ clear-selection ]
+  clear-selection
   [ pane-output clear-incremental ]
   [ pane-current clear-gadget ]
-    tri ;
+  bi ;
-
-: pane-theme ( pane -- pane )
-    selection-color >>selection-color ; inline
 
 : new-pane ( class -- pane )
     new-gadget
         { 0 1 } >>orientation
         <shelf> >>prototype
-        <incremental> over add-output
+        <incremental> add-output
-        dup prepare-line
+        prepare-line
-        pane-theme ;
+        selection-color >>selection-color ;
 
-: <pane> ( -- pane )
+: <pane> ( -- pane ) pane new-pane ;
-    pane new-pane ;
 
 GENERIC: draw-selection ( loc obj -- )
 
@@ -102,25 +91,25 @@ C: <pane-stream> pane-stream
 
 : smash-pane ( pane -- gadget ) pane-output smash-line ;
 
-: pane-nl ( pane -- )
+: pane-nl ( pane -- pane )
     dup pane-current dup unparent smash-line
     over pane-output add-incremental
     prepare-line ;
 
 : pane-write ( pane seq -- )
-    [ dup pane-nl ]
+    [ pane-nl ]
     [ over pane-current stream-write ]
     interleave drop ;
 
 : pane-format ( style pane seq -- )
-    [ dup pane-nl ]
+    [ pane-nl ]
     [ 2over pane-current stream-format ]
     interleave 2drop ;
 
 GENERIC: write-gadget ( gadget stream -- )
 
-M: pane-stream write-gadget
+M: pane-stream write-gadget ( gadget pane-stream -- )
-    pane-stream-pane pane-current swap add-gadget drop ;
+   pane>> current>> swap add-gadget drop ;
 
 M: style-stream write-gadget
     stream>> write-gadget ;
@@ -148,8 +137,8 @@ M: style-stream write-gadget
 
 TUPLE: pane-control < pane quot ;
 
-M: pane-control model-changed
+M: pane-control model-changed ( model pane-control -- )
-    swap model-value swap dup pane-control-quot with-pane ;
+   [ value>> ] [ dup quot>> ] bi* with-pane ;
 
 : <pane-control> ( model quot -- pane )
     pane-control new-pane
@@ -160,7 +149,7 @@ M: pane-control model-changed
     >r pane-stream-pane r> keep scroll-pane ; inline
 
 M: pane-stream stream-nl
-    [ pane-nl ] do-pane-stream ;
+    [ pane-nl drop ] do-pane-stream ;
 
 M: pane-stream stream-write1
     [ pane-current stream-write1 ] do-pane-stream ;
@@ -337,8 +326,9 @@ M: paragraph stream-format
         2drop
     ] if ;
 
-: caret>mark ( pane -- )
+: caret>mark ( pane -- pane )
-    dup pane-caret over set-pane-mark relayout-1 ;
+  dup caret>> >>mark
+  dup relayout-1 ;
 
 GENERIC: sloppy-pick-up* ( loc gadget -- n )
 
@@ -362,25 +352,25 @@ M: f sloppy-pick-up*
     [ 3drop { } ]
     if ;
 
-: move-caret ( pane -- )
+: move-caret ( pane -- pane )
   dup hand-rel
   over sloppy-pick-up
   over set-pane-caret
-    relayout-1 ;
+  dup relayout-1 ;
 
 : begin-selection ( pane -- )
-    dup move-caret f swap set-pane-mark ;
+    move-caret f swap set-pane-mark ;
 
 : extend-selection ( pane -- )
     hand-moved? [
         dup selecting?>> [
-            dup move-caret
+            move-caret
         ] [
             dup hand-clicked get child? [
                 t >>selecting?
                 dup hand-clicked set-global
-                dup move-caret
+                move-caret
-                dup caret>mark
+                caret>mark
             ] when
         ] if
         dup dup pane-caret gadget-at-path scroll>gadget
@@ -395,8 +385,8 @@ M: f sloppy-pick-up*
     ] if ;
 
 : select-to-caret ( pane -- )
-    dup pane-mark [ dup caret>mark ] unless
+    dup pane-mark [ caret>mark ] unless
-    dup move-caret
+    move-caret
     dup request-focus
     com-copy-selection ;