diff --git a/.gitignore b/.gitignore index f4334f3727..a7cbeeeef3 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ logs work build-support/wordsize *.bak +.#* diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index 1f488b3dde..e8082edb68 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -21,11 +21,3 @@ IN: compiler.utilities : map-flat ( seq quot -- seq' ) [ each ] flattening ; inline : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline - -: (3each) ( seq1 seq2 seq3 quot -- n quot' ) - [ [ [ length ] tri@ min min ] 3keep ] dip - '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 27911a8d13..aa9345e1d0 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: farkup kernel peg peg.ebnf tools.test namespaces ; +USING: farkup kernel peg peg.ebnf tools.test namespaces xml +urls.encoding assocs xml.utilities ; IN: farkup.tests relative-link-prefix off @@ -157,3 +158,12 @@ link-no-follow? off [ "

hello_world how are you today?\n

" ] [ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test + +: check-link-escaping ( string -- link ) + convert-farkup string>xml-chunk + "a" deep-tag-named "href" swap at url-decode ; + +[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test +[ "" ] [ "[[]]" check-link-escaping ] unit-test +[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test +[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test \ No newline at end of file diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 284d5758a3..1bfd420dd3 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -167,7 +167,7 @@ stand-alone } cond ; : escape-link ( href text -- href-esc text-esc ) - [ check-url escape-quoted-string ] dip escape-string ; + [ check-url ] dip escape-string ; : write-link ( href text -- ) escape-link diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1404491d10..bac4048706 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -359,6 +359,17 @@ HELP: 2bi* } } ; +HELP: 2tri* +{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( u v -- ... )" } } { "q" { $quotation "( w x -- ... )" } } { "r" { $quotation "( y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "u" } " and " { $snippet "v" } ", then applies " { $snippet "q" } " to " { $snippet "w" } " and " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 2tri*" + "[ [ p ] 2dip q ] 2dip r" + } +} ; + HELP: tri* { $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." } @@ -418,6 +429,22 @@ HELP: tri@ } } ; +HELP: 2tri@ +{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } } +{ $description "Applies the quotation to " { $snippet "u" } " and " { $snippet "v" } ", then to " { $snippet "w" } " and " { $snippet "x" } ", and then to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] 2tri@" + "[ [ p ] 2dip p ] 2dip p" + } + "The following two lines are also equivalent:" + { $code + "[ p ] 2tri@" + "[ p ] [ p ] [ p ] 2tri*" + } +} ; + HELP: if { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." @@ -595,12 +622,20 @@ HELP: 2dip HELP: 3dip { $values { "x" object } { "y" object } { "z" object } { "quot" quotation } } -{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." } { $notes "The following are equivalent:" { $code "[ [ [ foo bar ] dip ] dip ] dip" } { $code "[ foo bar ] 3dip" } } ; +HELP: 4dip +{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." } +{ $notes "The following are equivalent:" + { $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" } + { $code "[ foo bar ] 4dip" } +} ; + HELP: while { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; @@ -735,7 +770,7 @@ $nl { $subsection "cleave-shuffle-equivalence" } ; ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." $nl "Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" { $code @@ -775,6 +810,7 @@ $nl { $subsection 2bi* } "Three quotations:" { $subsection tri* } +{ $subsection 2tri* } "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code "! First alternative; uses dip" @@ -793,6 +829,7 @@ $nl { $subsection 2bi@ } "Three quotations:" { $subsection tri@ } +{ $subsection 2tri@ } "A pair of utility words built from " { $link bi@ } ":" { $subsection both? } { $subsection either? } ; @@ -804,6 +841,7 @@ $nl { $subsection dip } { $subsection 2dip } { $subsection 3dip } +{ $subsection 4dip } "The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" { $subsection slip } { $subsection 2slip } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index eae225e543..7ebaaeb3a8 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -163,3 +163,9 @@ IN: kernel.tests [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors last-frame ] unit-test + +[ 10 2 3 4 5 ] [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test + +[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test + +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test \ No newline at end of file diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d4df6fa407..a8f9281760 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -79,6 +79,8 @@ DEFER: if : 3dip ( x y z quot -- x y z ) -roll 3slip ; +: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline + ! Keepers : keep ( x quot -- x ) over slip ; inline @@ -118,6 +120,9 @@ DEFER: if : 2bi* ( w x y z p q -- ) [ 2dip ] dip call ; inline +: 2tri* ( u v w x y z p q r -- ) + [ 4dip ] 2dip 2bi* ; inline + ! Appliers : bi@ ( x y quot -- ) dup bi* ; inline @@ -129,6 +134,9 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline +: 2tri@ ( u v w y x z quot -- ) + dup dup 2tri* ; inline + ! Object protocol GENERIC: hashcode* ( depth obj -- code ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index b3df0b889f..9f18fd4e66 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1112,15 +1112,6 @@ HELP: virtual@ { "n'" integer } { "seq'" sequence } } { $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ; -HELP: 2change-each -{ $values - { "seq1" sequence } { "seq2" sequence } { "quot" quotation } } -{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." } -{ $examples { $example "USING: kernel math sequences prettyprint ;" - "{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ." - "{ 70 90 110 }" -} } ; - HELP: 2map-reduce { $values { "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index dcca525e2b..80352faf72 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -32,8 +32,8 @@ IN: sequences.tests [ 4 CHAR: o ] [ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test -[ f ] [ 3 [ ] member? ] unit-test -[ f ] [ 3 [ 1 2 ] member? ] unit-test +[ f ] [ 3 [ ] member? ] unit-test +[ f ] [ 3 [ 1 2 ] member? ] unit-test [ t ] [ 1 [ 1 2 ] member? ] unit-test [ t ] [ 2 [ 1 2 ] member? ] unit-test @@ -55,6 +55,11 @@ IN: sequences.tests [ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test +[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test +[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test + +[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test + [ "hello world how are you" ] [ { "hello" "world" "how" "are" "you" } " " join ] unit-test @@ -261,3 +266,14 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ "a,b" ] [ "a" "b" "," glue ] unit-test [ "(abc)" ] [ "abc" "(" ")" surround ] unit-test + +[ "HELLO" ] [ + "HELLO" { -1 -1 -1 -1 -1 } { 2 2 2 2 2 2 } + [ * 2 + + ] 3map +] unit-test + +{ 3 1 } [ [ 3array ] 3map ] must-infer-as + +{ 3 0 } [ [ 3drop ] 3each ] must-infer-as + +[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test \ No newline at end of file diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 40a8892e8b..91c9d52404 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private slots.private math math.private math.order ; @@ -117,9 +117,9 @@ INSTANCE: integer immutable-sequence [ tuck [ nth-unsafe ] 2bi@ ] [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline -: (head) ( seq n -- from to seq ) 0 spin ; inline +: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline -: (tail) ( seq n -- from to seq ) over length rot ; inline +: (tail) ( seq n -- from to seq ) swap [ length ] keep ; inline : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline @@ -346,11 +346,19 @@ PRIVATE> [ over ] dip [ nth-unsafe ] 2bi@ ; inline : (2each) ( seq1 seq2 quot -- n quot' ) - [ [ min-length ] 2keep ] dip - [ [ 2nth-unsafe ] dip call ] 3curry ; inline + [ + [ min-length ] 2keep + [ 2nth-unsafe ] 2curry + ] dip compose ; inline -: 2map-into ( seq1 seq2 quot into -- newseq ) - [ (2each) ] dip collect ; inline +: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 ) + [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline + +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ + [ [ length ] tri@ min min ] 3keep + [ 3nth-unsafe ] 3curry + ] dip compose ; inline : finish-find ( i seq -- i elt ) over [ dupd nth-unsafe ] [ drop f ] if ; inline @@ -407,18 +415,23 @@ PRIVATE> [ -rot ] dip 2each ; inline : 2map-as ( seq1 seq2 quot exemplar -- newseq ) - [ 2over min-length ] dip - [ [ 2map-into ] keep ] new-like ; inline + [ (2each) ] dip map-as ; inline : 2map ( seq1 seq2 quot -- newseq ) pick 2map-as ; inline -: 2change-each ( seq1 seq2 quot -- ) - pick 2map-into ; inline - : 2all? ( seq1 seq2 quot -- ? ) (2each) all-integers? ; inline +: 3each ( seq1 seq2 seq3 quot -- ) + (3each) each ; inline + +: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq ) + [ (3each) ] dip map-as ; inline + +: 3map ( seq1 seq2 seq3 quot -- newseq ) + [ pick ] dip swap 3map-as ; inline + : find-from ( n seq quot -- i elt ) [ (find-integer) ] (find-from) ; inline @@ -494,10 +507,12 @@ PRIVATE> : last-index-from ( obj i seq -- n ) rot [ = ] curry find-last-from drop ; +: (indices) ( elt i obj accum -- ) + [ swap [ = ] dip ] dip [ push ] 2curry when ; inline + : indices ( obj seq -- indices ) - V{ } clone spin - [ rot = [ over push ] [ drop ] if ] - curry each-index ; + swap V{ } clone + [ [ (indices) ] 2curry each-index ] keep ; : nths ( indices seq -- seq' ) [ nth ] curry map ; @@ -566,7 +581,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; PRIVATE> : filter-here ( seq quot -- ) - 0 0 roll (filter-here) ; inline + swap [ 0 0 ] dip (filter-here) ; inline : delete ( elt seq -- ) [ = not ] with filter-here ; @@ -828,7 +843,7 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: sigma ( seq quot -- n ) 0 -rot [ rot slip + ] curry each ; inline +: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline diff --git a/extra/faq/authors.txt b/extra/faq/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/faq/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor deleted file mode 100644 index 512817bc4d..0000000000 --- a/extra/faq/faq.factor +++ /dev/null @@ -1,113 +0,0 @@ -! Copyright (C) 2007 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: xml kernel sequences xml.utilities math xml.data -arrays assocs xml.generator xml.writer namespaces -make math.parser io accessors ; -IN: faq - -: find-after ( seq quot -- elem after ) - over [ find ] dip rot 1+ tail ; inline - -: tag-named*? ( tag name -- ? ) - assure-name swap tag-named? ; - -! Questions -TUPLE: q/a question answer ; -C: q/a - -: li>q/a ( li -- q/a ) - [ "br" tag-named*? not ] filter - [ "strong" tag-named*? ] find-after - [ children>> ] dip ; - -: q/a>li ( q/a -- li ) - [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep - answer>> append "li" build-tag* ; - -: xml>q/a ( xml -- q/a ) - [ "question" tag-named children>> ] keep - "answer" tag-named children>> ; - -: q/a>xml ( q/a -- xml ) - [ question>> "question" build-tag* ] keep - answer>> "answer" build-tag* - "\n" swap 3array "qa" build-tag* ; - -! Lists of questions -TUPLE: question-list title seq ; -C: question-list - -: xml>question-list ( list -- question-list ) - [ "title" swap at ] keep - children>> [ tag? ] filter [ xml>q/a ] map - ; - -: question-list>xml ( question-list -- list ) - [ seq>> [ q/a>xml "\n" swap 2array ] - map concat "list" build-tag* ] keep - title>> [ "title" pick set-at ] when* ; - -: html>question-list ( h3 ol -- question-list ) - [ [ children>string ] [ f ] if* ] dip - children-tags [ li>q/a ] map ; - -: question-list>h3 ( id question-list -- h3 ) - title>> [ - "h3" build-tag - swap number>string "id" pick set-at - ] [ drop f ] if* ; - -: question-list>html ( question-list start id -- h3/f ol ) - -rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip - number>string "start" pick set-at - "margin-left: 5em" "style" pick set-at ; - -! Overall everything -TUPLE: faq header lists ; -C: faq - -: html>faq ( div -- faq ) - unclip swap { "h3" "ol" } [ tags-named ] with map - first2 [ f prefix ] dip [ html>question-list ] 2map ; - -: header, ( faq -- ) - dup header>> , - lists>> first 1 -1 question-list>html nip , ; - -: br, ( -- ) - "br" contained, nl, ; - -: toc-link, ( question-list number -- ) - number>string "#" prepend "href" swap 2array 1array - "a" swap [ title>> , ] tag*, br, ; - -: toc, ( faq -- ) - "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ - "strong" [ "The big questions" , ] tag, br, - lists>> rest dup length [ toc-link, ] 2each - ] tag*, ; - -: faq-sections, ( question-lists -- ) - unclip seq>> length 1+ dupd - [ seq>> length + ] accumulate nip - 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ; - -: faq>html ( faq -- div ) - "div" [ - dup header, - dup toc, - lists>> faq-sections, - ] make-xml ; - -: xml>faq ( xml -- faq ) - [ "header" tag-named children>string ] keep - "list" tags-named [ xml>question-list ] map ; - -: faq>xml ( faq -- xml ) - "faq" [ - "header" [ dup header>> , ] tag, - lists>> [ question-list>xml , nl, ] each - ] make-xml ; - -: read-write-faq ( xml-stream -- ) - read-xml xml>faq faq>html write-xml ; diff --git a/extra/faq/summary.txt b/extra/faq/summary.txt deleted file mode 100755 index c33f8cffeb..0000000000 --- a/extra/faq/summary.txt +++ /dev/null @@ -1 +0,0 @@ -The Factor FAQ diff --git a/license.txt b/license.txt index 768c13c549..8f4f53585a 100644 --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright (C) 2003, 2008 Slava Pestov and friends. +Copyright (C) 2003, 2009 Slava Pestov and friends. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: