diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor
index 3b1a5c6c85..1085feb0c6 100755
--- a/core/compiler/tests/stack-trace.factor
+++ b/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
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index ab808d7914..1e659f1b99 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/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 ] [
diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor
index e55d1eb150..18bc7f14cf 100644
--- a/core/sorting/sorting-docs.factor
+++ b/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:"
diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor
index 5f3dab14bc..63e193c89f 100755
--- a/core/sorting/sorting-tests.factor
+++ b/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
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
index a93a30e7f2..8b84ea8fe0 100755
--- a/core/sorting/sorting.factor
+++ b/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 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
diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor
new file mode 100644
index 0000000000..e9a5ad0ed8
--- /dev/null
+++ b/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 ] [ [ 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 ;
diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor
index df72572c67..3300faa125 100755
--- a/extra/channels/channels-tests.factor
+++ b/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
[ 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
[ 4 swap to ] in-thread
[ 2 swap to ] in-thread
diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor
deleted file mode 100644
index 5674120196..0000000000
--- a/extra/farkup/authors.factor
+++ /dev/null
@@ -1,2 +0,0 @@
-Doug Coleman
-Slava Pestov
diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt
index 7c1b2f2279..5674120196 100644
--- a/extra/farkup/authors.txt
+++ b/extra/farkup/authors.txt
@@ -1 +1,2 @@
Doug Coleman
+Slava Pestov
diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
old mode 100755
new mode 100644
index 17d286252e..005e875d89
--- a/extra/farkup/farkup-tests.factor
+++ b/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
-[ "" ] [ "-foo" convert-farkup ] unit-test
-[ "\n" ] [ "-foo\n" convert-farkup ] unit-test
-[ "" ] [ "-foo\n-bar" convert-farkup ] unit-test
-[ "\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23"
+ "paragraph" \ farkup rule parse drop
+] unit-test
-[ "\nbar\n
" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+ "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ "a-b
" ] [ "a-b" convert-farkup ] unit-test
[ "*foo\nbar\n
" ] [ "*foo\nbar\n" convert-farkup ] unit-test
[ "Wow!
" ] [ "*Wow!*" convert-farkup ] unit-test
[ "Wow.
" ] [ "_Wow._" convert-farkup ] unit-test
@@ -15,11 +22,20 @@ IN: farkup.tests
[ "*
" ] [ "\\*" convert-farkup ] unit-test
[ "**
" ] [ "\\**" convert-farkup ] unit-test
-[ "" ] [ "\n\n" convert-farkup ] unit-test
-[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
-[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "" ] [ "-a-b" convert-farkup ] unit-test
+[ "" ] [ "-foo" convert-farkup ] unit-test
+[ "" ] [ "-foo\n" convert-farkup ] unit-test
+[ "" ] [ "-foo\n-bar" convert-farkup ] unit-test
+[ "" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "bar\n
" ] [ "-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
[ "foo
bar
" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "foo
bar
" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "foo
bar
" ] [ "foo\r\rbar" convert-farkup ] unit-test
@@ -29,7 +45,7 @@ IN: farkup.tests
[ "\nbar\n
" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\nbar\n
" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
-[ "foo
\nbar
" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "foo
bar
" ] [ "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
[
- "Feature comparison:\n\n
a | Factor | Java | Lisp |
Coolness | Yes | No | No |
Badass | Yes | No | No |
Enterprise | Yes | Yes | No |
Kosher | Yes | No | Yes |
"
+ "Feature comparison:
a | Factor | Java | Lisp |
Coolness | Yes | No | No |
Badass | Yes | No | No |
Enterprise | Yes | Yes | No |
Kosher | Yes | No | Yes |
"
] [ "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
-
-[ "a-b
" ] [ "a-b" convert-farkup ] unit-test
-[ "" ] [ "-a-b" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
old mode 100755
new mode 100644
index 321648136a..baf2ccaba2
--- a/extra/farkup/farkup.factor
+++ b/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
-combinators sequences strings html.elements xml.entities
-xmode.code2html splitting io.streams.string peg.parsers
-sequences.deep unicode.categories ;
+USING: accessors arrays combinators html.elements io io.streams.string
+kernel math memoize namespaces peg peg.ebnf prettyprint
+sequences sequences.deep strings xml.entities vectors splitting
+xmode.code2html ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
- [[ drop "\n" ]]
+2nl = nl nl
-MEMO: text ( -- parser )
- [ delimiters member? not ] satisfy repeat1
- [ >string escape-string ] action ;
+heading1 = "=" (!("=" | nl).)+ "="
+ => [[ second >string heading1 boa ]]
-MEMO: delimiter ( -- parser )
- [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
- [ 1string ] action ;
+heading2 = "==" (!("=" | nl).)+ "=="
+ => [[ second >string heading2 boa ]]
-: surround-with-foo ( string tag -- seq )
- dup swap swapd 3array ;
+heading3 = "===" (!("=" | nl).)+ "==="
+ => [[ second >string heading3 boa ]]
-: delimited ( str html -- parser )
- [
- over token hide ,
- text [ surround-with-foo ] swapd curry action ,
- token hide ,
- ] seq* ;
+heading4 = "====" (!("=" | nl).)+ "===="
+ => [[ second >string heading4 boa ]]
-MEMO: escaped-char ( -- parser )
- [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+strong = "*" (!("*" | nl).)+ "*"
+ => [[ second >string strong boa ]]
-MEMO: strong ( -- parser ) "*" "strong" delimited ;
-MEMO: emphasis ( -- parser ) "_" "em" delimited ;
-MEMO: superscript ( -- parser ) "^" "sup" delimited ;
-MEMO: subscript ( -- parser ) "~" "sub" delimited ;
-MEMO: inline-code ( -- parser ) "%" "code" delimited ;
-MEMO: nl ( -- parser )
- "\r\n" token [ drop "\n" ] action
- "\r" token [ drop "\n" ] action
- "\n" token 3choice ;
-MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
-MEMO: h1 ( -- parser ) "=" "h1" delimited ;
-MEMO: h2 ( -- parser ) "==" "h2" delimited ;
-MEMO: h3 ( -- parser ) "===" "h3" delimited ;
-MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+emphasis = "_" (!("_" | nl).)+ "_"
+ => [[ second >string emphasis boa ]]
+
+superscript = "^" (!("^" | nl).)+ "^"
+ => [[ second >string superscript boa ]]
+
+subscript = "~" (!("~" | nl).)+ "~"
+ => [[ second >string subscript boa ]]
+
+inline-code = "%" (!("%" | nl).)+ "%"
+ => [[ second >string inline-code boa ]]
+
+escaped-char = "\" . => [[ second ]]
+
+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>
- [
-
- htmlize-lines
-
- ] 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
- [
- "r , r> "\"" ,
- link-no-follow? get [ " nofollow=\"true\"" , ] when
- ">" , , "" ,
- ] { } make ;
+ "" write write "" write ;
-: make-image-link ( href alt -- seq )
+: write-image-link ( href text -- )
disable-images? get [
- 2drop "Images are not allowed"
+ 2drop "Images are not allowed" write
] [
escape-link
- [
- "
" ,
- ] { } make
+ >r "
+ dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
+ "/>" write
] if ;
-MEMO: image-link ( -- parser )
+: render-code ( string mode -- string' )
+ >r string-lines r>
[
- "[[image:" token hide ,
- [ "|]" member? not ] satisfy repeat1 [ >string ] action ,
- "|" token hide
- [ CHAR: ] = not ] satisfy repeat0 2seq
- [ first >string ] action optional ,
- "]]" token hide ,
- ] seq* [ first2 make-image-link ] action ;
+
+ htmlize-lines
+
+ ] with-string-writer write ;
-MEMO: simple-link ( -- parser )
- [
- "[[" token hide ,
- [ "|]" member? not ] satisfy repeat1 ,
- "]]" token hide ,
- ] seq* [ first dup make-link ] action ;
-
-MEMO: labelled-link ( -- parser )
- [
- "[[" token hide ,
- [ CHAR: | = not ] satisfy repeat1 ,
- "|" token hide ,
- [ CHAR: ] = not ] satisfy repeat1 ,
- "]]" token hide ,
- ] seq* [ first2 make-link ] action ;
-
-MEMO: link ( -- parser )
- [ image-link , simple-link , labelled-link , ] choice* ;
-
-DEFER: line
-MEMO: list-item ( -- parser )
- [
- "-" token hide , ! text ,
- [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
- ] seq* [ "li" surround-with-foo ] action ;
-
-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?
- [ "" swap "
" 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 ;
+GENERIC: write-farkup ( obj -- )
+: ( string -- ) write ;
+: ( string -- ) write ;
+: in-tag. ( obj quot string -- ) [ call ] keep ; inline
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: table-row write-farkup ( obj -- )
+ obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
+M: fixnum write-farkup ( obj -- ) write1 ;
+M: string write-farkup ( obj -- ) write ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
+M: f write-farkup ( obj -- ) drop ;
: convert-farkup ( string -- string' )
- parse-farkup [ write-farkup ] with-string-writer ;
+ farkup [ write-farkup ] with-string-writer ;
diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor
index d5baf4914c..991551c009 100644
--- a/extra/multi-methods/tests/canonicalize.factor
+++ b/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
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 7f14293a15..45e1e9b218 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -449,7 +449,7 @@ foo= 'd'
] unit-test
[
- "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
+ "USING: peg.ebnf ; " eval drop
] must-fail
{ t } [
@@ -519,4 +519,4 @@ Tok = Spaces (Number | Special )
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 2a75fcccc0..cc94a215e6 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/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
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 9b547ce544..31a7249a79 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/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.paragraphs ui.gadgets.incremental ui.gadgets.packs
-ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
-hashtables io kernel namespaces sequences io.styles strings
-quotations math opengl combinators math.vectors
-sorting splitting io.streams.nested assocs
-ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines classes.tuple models continuations
-destructors accessors math.geometry.rect ;
+ ui.gadgets.labels ui.gadgets.scrollers
+ ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
+ ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
+ hashtables io kernel namespaces sequences io.styles strings
+ quotations math opengl combinators math.vectors
+ sorting splitting io.streams.nested assocs
+ ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
+ ui.gadgets.grid-lines classes.tuple models continuations
+ destructors accessors math.geometry.rect ;
+
IN: ui.gadgets.panes
TUPLE: pane < pack
-output current prototype scrolls?
-selection-color caret mark selecting? ;
+ output current prototype scrolls?
+ selection-color caret mark selecting? ;
-: clear-selection ( pane -- )
- f >>caret
- f >>mark
- drop ;
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-: add-output ( current pane -- )
- [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
+: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
-: add-current ( current pane -- )
- [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
+: prepare-line ( pane -- pane )
+ clear-selection
+ dup prototype>> clone add-current ;
-: prepare-line ( pane -- )
- [ clear-selection ]
- [ [ pane-prototype clone ] keep add-current ] bi ;
-
-: pane-caret&mark ( pane -- caret mark )
- [ caret>> ] [ mark>> ] 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
- selected-children gadget-text ;
+M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
: pane-clear ( pane -- )
- [ clear-selection ]
- [ pane-output clear-incremental ]
- [ pane-current clear-gadget ]
- tri ;
-
-: pane-theme ( pane -- pane )
- selection-color >>selection-color ; inline
+ clear-selection
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ bi ;
: new-pane ( class -- pane )
new-gadget
{ 0 1 } >>orientation
>>prototype
- over add-output
- dup prepare-line
- pane-theme ;
+ add-output
+ prepare-line
+ selection-color >>selection-color ;
-: ( -- pane )
- pane new-pane ;
+: ( -- pane ) pane new-pane ;
GENERIC: draw-selection ( loc obj -- )
@@ -102,25 +91,25 @@ C: 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
- pane-stream-pane pane-current swap add-gadget drop ;
+M: pane-stream write-gadget ( gadget pane-stream -- )
+ 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
- swap model-value swap dup pane-control-quot with-pane ;
+M: pane-control model-changed ( model pane-control -- )
+ [ value>> ] [ dup quot>> ] bi* with-pane ;
: ( 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 -- )
- dup pane-caret over set-pane-mark relayout-1 ;
+: caret>mark ( pane -- pane )
+ 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 -- )
- dup hand-rel
- over sloppy-pick-up
- over set-pane-caret
- relayout-1 ;
+: move-caret ( pane -- pane )
+ dup hand-rel
+ over sloppy-pick-up
+ over set-pane-caret
+ 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
- dup caret>mark
+ move-caret
+ 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 move-caret
+ dup pane-mark [ caret>mark ] unless
+ move-caret
dup request-focus
com-copy-selection ;