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
" ] [ "-foo" convert-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] unit-test -[ "
  • foo
\n

bar\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
" ] [ "-a-b" convert-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
  • \n
" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
  • \n
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
  • \n
  • bar
  • \n
" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
  • \n

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 [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "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
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" + "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "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
" ] [ "-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 ;