From 1660be50a477ee75c77808467a1b8d4ceadb7cc0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 1 Aug 2009 20:42:29 -0500 Subject: [PATCH 1/9] remove some c parsing words from sequence-parser --- extra/c/lexer/authors.txt | 1 + extra/c/lexer/lexer-tests.factor | 103 +++++++++++++++ extra/c/lexer/lexer.factor | 123 ++++++++++++++++++ extra/c/preprocessor/preprocessor.factor | 2 +- .../sequence-parser-tests.factor | 98 -------------- extra/sequence-parser/sequence-parser.factor | 119 +---------------- 6 files changed, 231 insertions(+), 215 deletions(-) create mode 100644 extra/c/lexer/authors.txt create mode 100644 extra/c/lexer/lexer-tests.factor create mode 100644 extra/c/lexer/lexer.factor diff --git a/extra/c/lexer/authors.txt b/extra/c/lexer/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/c/lexer/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor new file mode 100644 index 0000000000..c972b8816c --- /dev/null +++ b/extra/c/lexer/lexer-tests.factor @@ -0,0 +1,103 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors c.lexer kernel sequence-parser tools.test ; +IN: c.lexer.tests + +[ 36 ] +[ + " //jofiejoe\n //eoieow\n/*asdf*/\n " + skip-whitespace/comments n>> +] unit-test + +[ f "33asdf" ] +[ "33asdf" [ take-c-identifier ] [ take-rest ] bi ] unit-test + +[ "asdf" ] +[ "asdf" take-c-identifier ] unit-test + +[ "_asdf" ] +[ "_asdf" take-c-identifier ] unit-test + +[ "_asdf400" ] +[ "_asdf400" take-c-identifier ] unit-test + +[ "asdfasdf" ] [ + "/*asdfasdf*/" take-c-comment +] unit-test + +[ "k" ] [ + "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "omg" ] [ + "//asdfasdf\nomg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + +[ "omg" ] [ + "omg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + +[ "/*asdfasdf" ] [ + "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "asdf" "eoieoei" ] [ + "//asdf\neoieoei" + [ take-c++-comment ] [ take-rest ] bi +] unit-test + +[ f ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi +] unit-test + +[ "abc\\\"def" ] +[ + "\"abc\\\"def\" asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "asdf" ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ skip-whitespace "asdf" take-sequence ] bi +] unit-test + +[ f ] +[ + "\"abc asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "\"abc" ] +[ + "\"abc asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ "\"abc" take-sequence ] bi +] unit-test + +[ "c" ] +[ "c" take-token ] unit-test + +[ f ] +[ "" take-token ] unit-test + +[ "abcd e \\\"f g" ] +[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test + +[ "123" ] +[ "123jjj" take-c-integer ] unit-test + +[ "123uLL" ] +[ "123uLL" take-c-integer ] unit-test + +[ "123ull" ] +[ "123ull" take-c-integer ] unit-test + +[ "123u" ] +[ "123u" take-c-integer ] unit-test + diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor new file mode 100644 index 0000000000..962407e6ec --- /dev/null +++ b/extra/c/lexer/lexer.factor @@ -0,0 +1,123 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.short-circuit +generalizations kernel locals math.order math.ranges +sequence-parser sequences sorting.functor sorting.slots +unicode.categories ; +IN: c.lexer + +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + +: take-c++-comment ( sequence-parser -- seq/f ) + [ + dup "//" take-sequence [ + [ + [ + { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| + ] take-until + ] [ + advance drop + ] bi + ] [ + drop f + ] if + ] with-sequence-parser ; + +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace-eol + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + +:: take-quoted-string ( sequence-parser escape-char quote-char -- string ) + sequence-parser n>> :> start-n + sequence-parser advance + [ + { + [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] + [ current quote-char = not ] + } 1|| + ] take-while :> string + sequence-parser current quote-char = [ + sequence-parser advance* string + ] [ + start-n sequence-parser (>>n) f + ] if ; + +: (take-token) ( sequence-parser -- string ) + skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; + +:: take-token* ( sequence-parser escape-char quote-char -- string/f ) + sequence-parser skip-whitespace + dup current { + { quote-char [ escape-char quote-char take-quoted-string ] } + { f [ drop f ] } + [ drop (take-token) ] + } case ; + +: take-token ( sequence-parser -- string/f ) + CHAR: \ CHAR: " take-token* ; + +: c-identifier-begin? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + { CHAR: _ } 3append member? ; + +: c-identifier-ch? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 0 CHAR: 9 [a,b] + { CHAR: _ } 4 nappend member? ; + +: (take-c-identifier) ( sequence-parser -- string/f ) + dup current c-identifier-begin? [ + [ current c-identifier-ch? ] take-while + ] [ + drop f + ] if ; + +: take-c-identifier ( sequence-parser -- string/f ) + [ (take-c-identifier) ] with-sequence-parser ; + +<< "length" [ length ] define-sorting >> + +: sort-tokens ( seq -- seq' ) + { length>=< <=> } sort-by ; + +: take-c-integer ( sequence-parser -- string/f ) + [ + dup take-integer [ + swap + { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" } + take-longest [ append ] when* + ] [ + drop f + ] if* + ] with-sequence-parser ; + +CONSTANT: c-punctuators + { + "[" "]" "(" ")" "{" "}" "." "->" + "++" "--" "&" "*" "+" "-" "~" "!" + "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" + "?" ":" ";" "..." + "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" + "," "#" "##" + "<:" ":>" "<%" "%>" "%:" "%:%:" + } + +: take-c-punctuator ( sequence-parser -- string/f ) + c-punctuators take-longest ; diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f787befc31..3018fa7a24 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -4,7 +4,7 @@ USING: sequence-parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories -combinators.short-circuit ; +combinators.short-circuit c.lexer ; IN: c.preprocessor : initial-library-paths ( -- seq ) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 259fb9f259..af13e5b86e 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -77,47 +77,6 @@ IN: sequence-parser.tests [ "cd" ] [ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test -[ f ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi -] unit-test - -[ "abc\\\"def" ] -[ - "\"abc\\\"def\" asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "asdf" ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ skip-whitespace "asdf" take-sequence ] bi -] unit-test - -[ f ] -[ - "\"abc asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "\"abc" ] -[ - "\"abc asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ "\"abc" take-sequence ] bi -] unit-test - -[ "c" ] -[ "c" take-token ] unit-test - -[ f ] -[ "" take-token ] unit-test - -[ "abcd e \\\"f g" ] -[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test - [ f ] [ "" take-rest ] unit-test @@ -140,63 +99,6 @@ IN: sequence-parser.tests [ "abcd" ] [ "abcd" 4 take-n ] unit-test [ "abcd" "efg" ] [ "abcdefg" [ 4 take-n ] [ take-rest ] bi ] unit-test -[ "asdfasdf" ] [ - "/*asdfasdf*/" take-c-comment -] unit-test - -[ "k" ] [ - "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi -] unit-test - -[ "omg" ] [ - "//asdfasdf\nomg" - [ take-c++-comment drop ] [ take-rest ] bi -] unit-test - -[ "omg" ] [ - "omg" - [ take-c++-comment drop ] [ take-rest ] bi -] unit-test - -[ "/*asdfasdf" ] [ - "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi -] unit-test - -[ "asdf" "eoieoei" ] [ - "//asdf\neoieoei" - [ take-c++-comment ] [ take-rest ] bi -] unit-test - -[ f "33asdf" ] -[ "33asdf" [ take-c-identifier ] [ take-rest ] bi ] unit-test - -[ "asdf" ] -[ "asdf" take-c-identifier ] unit-test - -[ "_asdf" ] -[ "_asdf" take-c-identifier ] unit-test - -[ "_asdf400" ] -[ "_asdf400" take-c-identifier ] unit-test - -[ "123" ] -[ "123jjj" take-c-integer ] unit-test - -[ "123uLL" ] -[ "123uLL" take-c-integer ] unit-test - -[ "123ull" ] -[ "123ull" take-c-integer ] unit-test - -[ "123u" ] -[ "123u" take-c-integer ] unit-test - -[ 36 ] -[ - " //jofiejoe\n //eoieow\n/*asdf*/\n " - skip-whitespace/comments n>> -] unit-test - [ f ] [ "\n" take-integer ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index e46abe8090..0a6f3ef0db 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting math.parser math.ranges -generalizations sorting.functor math.order sorting.slots ; +USING: accessors circular combinators.short-circuit fry io +kernel locals math math.order sequences sorting.functor +sorting.slots unicode.categories ; IN: sequence-parser TUPLE: sequence-parser sequence n ; @@ -109,42 +108,6 @@ TUPLE: sequence-parser sequence n ; : skip-whitespace-eol ( sequence-parser -- sequence-parser ) [ [ current " \t\r" member? not ] take-until drop ] keep ; -: take-c-comment ( sequence-parser -- seq/f ) - [ - dup "/*" take-sequence [ - "*/" take-until-sequence* - ] [ - drop f - ] if - ] with-sequence-parser ; - -: take-c++-comment ( sequence-parser -- seq/f ) - [ - dup "//" take-sequence [ - [ - [ - { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| - ] take-until - ] [ - advance drop - ] bi - ] [ - drop f - ] if - ] with-sequence-parser ; - -: skip-whitespace/comments ( sequence-parser -- sequence-parser ) - skip-whitespace-eol - { - { [ dup take-c-comment ] [ skip-whitespace/comments ] } - { [ dup take-c++-comment ] [ skip-whitespace/comments ] } - [ ] - } cond ; - -: take-define-identifier ( sequence-parser -- string ) - skip-whitespace/comments - [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; - : take-rest-slice ( sequence-parser -- sequence/f ) [ sequence>> ] [ n>> ] bi 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline @@ -158,35 +121,6 @@ TUPLE: sequence-parser sequence n ; : parse-sequence ( sequence quot -- ) [ ] dip call ; inline -:: take-quoted-string ( sequence-parser escape-char quote-char -- string ) - sequence-parser n>> :> start-n - sequence-parser advance - [ - { - [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] - [ current quote-char = not ] - } 1|| - ] take-while :> string - sequence-parser current quote-char = [ - sequence-parser advance* string - ] [ - start-n sequence-parser (>>n) f - ] if ; - -: (take-token) ( sequence-parser -- string ) - skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; - -:: take-token* ( sequence-parser escape-char quote-char -- string/f ) - sequence-parser skip-whitespace - dup current { - { quote-char [ escape-char quote-char take-quoted-string ] } - { f [ drop f ] } - [ drop (take-token) ] - } case ; - -: take-token ( sequence-parser -- string/f ) - CHAR: \ CHAR: " take-token* ; - : take-integer ( sequence-parser -- n/f ) [ current digit? ] take-while ; @@ -198,27 +132,6 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ n + ] change-n drop ] if ; -: c-identifier-begin? ( ch -- ? ) - CHAR: a CHAR: z [a,b] - CHAR: A CHAR: Z [a,b] - { CHAR: _ } 3append member? ; - -: c-identifier-ch? ( ch -- ? ) - CHAR: a CHAR: z [a,b] - CHAR: A CHAR: Z [a,b] - CHAR: 0 CHAR: 9 [a,b] - { CHAR: _ } 4 nappend member? ; - -: (take-c-identifier) ( sequence-parser -- string/f ) - dup current c-identifier-begin? [ - [ current c-identifier-ch? ] take-while - ] [ - drop f - ] if ; - -: take-c-identifier ( sequence-parser -- string/f ) - [ (take-c-identifier) ] with-sequence-parser ; - << "length" [ length ] define-sorting >> : sort-tokens ( seq -- seq' ) @@ -228,34 +141,8 @@ TUPLE: sequence-parser sequence n ; swap '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ; - : take-longest ( sequence-parser seq -- seq ) sort-tokens take-first-matching ; -: take-c-integer ( sequence-parser -- string/f ) - [ - dup take-integer [ - swap - { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" } - take-longest [ append ] when* - ] [ - drop f - ] if* - ] with-sequence-parser ; - -CONSTANT: c-punctuators - { - "[" "]" "(" ")" "{" "}" "." "->" - "++" "--" "&" "*" "+" "-" "~" "!" - "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" - "?" ":" ";" "..." - "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" - "," "#" "##" - "<:" ":>" "<%" "%>" "%:" "%:%:" - } - -: take-c-punctuator ( sequence-parser -- string/f ) - c-punctuators take-longest ; - : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From eb61ffc56d34ffe7259bee95080d949418d495c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 2 Aug 2009 18:18:31 -0500 Subject: [PATCH 2/9] use itoa in more places --- core/checksums/checksums.factor | 2 +- core/combinators/combinators.factor | 2 +- core/generic/single/single.factor | 2 +- core/io/binary/binary.factor | 2 +- core/sequences/sequences.factor | 6 +++--- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 0dd808c722..5fe46b532f 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -56,7 +56,7 @@ M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; : checksum-file ( path checksum -- value ) - #! normalize-path (file-reader) is equivalen to + #! normalize-path (file-reader) is equivalent to #! binary . We use the lower-level form #! so that we can move io.encodings.binary to basis/. [ normalize-path (file-reader) ] dip checksum-stream ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 54037b899e..2bef1a568a 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -113,7 +113,7 @@ ERROR: no-case object ; ] if ; : ( initial length -- array ) - next-power-of-2 swap [ nip clone ] curry map ; + next-power-of-2 iota swap [ nip clone ] curry map ; : distribute-buckets ( alist initial quot -- buckets ) swapd [ [ dup first ] dip call 2array ] curry map diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 9a773f43a2..88387abd5c 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -145,7 +145,7 @@ GENERIC: compile-engine ( engine -- obj ) default get [ swap update ] keep ; : lo-tag-number ( class -- n ) - "type" word-prop dup num-tags get member? + "type" word-prop dup num-tags get iota member? [ drop object tag-number ] unless ; M: tag-dispatch-engine compile-engine diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index cf2781aac0..f5467daea6 100644 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,7 +10,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ; +: >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ; : >be ( x n -- byte-array ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 17dbcf5c3c..92a3495ba8 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -701,7 +701,7 @@ PRIVATE> 3tri ; : reverse-here ( seq -- ) - [ length 2/ ] [ length ] [ ] tri + [ length 2/ iota ] [ length ] [ ] tri [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; : reverse ( seq -- newseq ) @@ -805,14 +805,14 @@ PRIVATE> : start* ( subseq seq n -- i ) - pick length pick length swap - 1 + + pick length pick length swap - 1 + iota [ (start) ] find-from swap [ 3drop ] dip ; From f0f20708cd647949155e2a461b35ca7c3e789b19 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 19:52:33 -0500 Subject: [PATCH 3/9] gpu.render: remove gpu-data-ptr slot specialization on index-elements. it prevents using specialized-arrays or other byte-array wrappers with index-elements --- extra/gpu/render/render.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 8f1679bfa8..35e137a235 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -73,7 +73,7 @@ TUPLE: multi-index-range C: multi-index-range TUPLE: index-elements - { ptr gpu-data-ptr read-only } + { ptr read-only } { count integer read-only } { index-type index-type read-only } ; From cdf964579d822938c36713aa99ad52bde93b0788 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:01:54 -0500 Subject: [PATCH 4/9] sorting: sort-with and inv-sort-with combinators to simplify common [ [ ... ] compare ] sort idiom --- core/sorting/sorting-docs.factor | 18 ++++++++++++++---- core/sorting/sorting.factor | 5 +++++ 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 290ca1470c..c30c06a989 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -12,6 +12,8 @@ $nl "Sorting a sequence with a custom comparator:" { $subsection sort } "Sorting a sequence with common comparators:" +{ $subsection sort-with } +{ $subsection inv-sort-with } { $subsection natural-sort } { $subsection sort-keys } { $subsection sort-values } ; @@ -20,16 +22,24 @@ ABOUT: "sequences-sorting" HELP: sort { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements into a new array using a stable sort." } +{ $description "Sorts the elements of " { $snippet "seq" } " into a new array using a stable sort." } { $notes "The algorithm used is the merge sort." } ; +HELP: sort-with +{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } } +{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence." } ; + +HELP: inv-sort-with +{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } } +{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence and inverting the results." } ; + HELP: sort-keys { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing first elements of pairs using the " { $link <=> } " word." } ; +{ $description "Sorts the elements of " { $snippet "seq" } " comparing first elements of pairs using the " { $link <=> } " word." } ; HELP: sort-values { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing second elements of pairs using the " { $link <=> } " word." } ; +{ $description "Sorts the elements of " { $snippet "seq" } " comparing second elements of pairs using the " { $link <=> } " word." } ; HELP: natural-sort { $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } } @@ -43,4 +53,4 @@ HELP: midpoint@ { $values { "seq" "a sequence" } { "n" integer } } { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ; -{ <=> compare natural-sort sort-keys sort-values } related-words +{ <=> compare natural-sort sort-with inv-sort-with sort-keys sort-values } related-words diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 0c0951bbce..312ddcd9be 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -155,6 +155,11 @@ PRIVATE> : natural-sort ( seq -- sortedseq ) [ <=> ] sort ; +: sort-with ( seq quot -- sortedseq ) + [ compare ] curry sort ; inline +: inv-sort-with ( seq quot -- sortedseq ) + [ compare invert-comparison ] curry sort ; inline + : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ; : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; From 7c5ef08aabdbf4033b24b5b28464bed82240200f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:09:23 -0500 Subject: [PATCH 5/9] [ [ ... ] compare ] sort => [ ... ] sort-with --- basis/compiler/cfg/ssa/interference/interference.factor | 2 +- basis/heaps/heaps-tests.factor | 2 +- basis/help/html/html.factor | 2 +- basis/interval-maps/interval-maps.factor | 2 +- basis/splitting/monotonic/monotonic.factor | 2 +- basis/ui/gadgets/menus/menus.factor | 2 +- basis/ui/tools/inspector/inspector.factor | 2 +- basis/vocabs/prettyprint/prettyprint.factor | 2 +- core/classes/algebra/algebra.factor | 2 +- core/sorting/sorting.factor | 4 ++-- core/source-files/errors/errors.factor | 2 +- extra/dns/util/util.factor | 2 +- extra/webapps/pastebin/pastebin.factor | 2 +- extra/webapps/planet/planet.factor | 2 +- extra/webapps/wiki/wiki.factor | 2 +- 15 files changed, 16 insertions(+), 16 deletions(-) diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor index f8553ec9de..dd002ec977 100644 --- a/basis/compiler/cfg/ssa/interference/interference.factor +++ b/basis/compiler/cfg/ssa/interference/interference.factor @@ -58,7 +58,7 @@ PRIVATE> : sort-vregs-by-bb ( vregs -- alist ) defs get '[ dup _ at ] { } map>assoc - [ [ second pre-of ] compare ] sort ; + [ second pre-of ] sort-with ; : ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index b476107562..c1985c516f 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -52,7 +52,7 @@ IN: heaps.tests ] each : sort-entries ( entries -- entries' ) - [ [ key>> ] compare ] sort ; + [ key>> ] sort-with ; : delete-test ( n -- obj1 obj2 ) [ diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 84f708a687..6f87549619 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -115,7 +115,7 @@ TUPLE: result title href ; load-index swap >lower '[ [ drop _ ] dip >lower subseq? ] assoc-filter [ swap result boa ] { } assoc>map - [ [ title>> ] compare ] sort ; + [ title>> ] sort-with ; : article-apropos ( string -- results ) "articles.idx" offline-apropos ; diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 22283deecb..b94266282c 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -46,7 +46,7 @@ PRIVATE> array>> [ value ] map ; : ( specification -- map ) - all-intervals [ [ first second ] compare ] sort + all-intervals [ first second ] sort-with >intervals ensure-disjoint interval-map boa ; : ( specification -- map ) diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 088de52766..3dec6130de 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -64,6 +64,6 @@ TUPLE: upward-slice < slice ; drop [ downward-slices ] [ stable-slices ] - [ upward-slices ] tri 3append [ [ from>> ] compare ] sort + [ upward-slices ] tri 3append [ from>> ] sort-with ] } case ; diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 159da59be5..70818262c5 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -65,7 +65,7 @@ M: ---- : ( target hook -- menu ) over object-operations [ primary-operation? ] partition - [ reverse ] [ [ [ command-name ] compare ] sort ] bi* + [ reverse ] [ [ command-name ] sort-with ] bi* { ---- } glue ; : show-operations-menu ( gadget target hook -- ) diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index 35fa5e3c17..b4a772dca5 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -57,7 +57,7 @@ M: object make-slot-descriptions make-mirror [ ] { } assoc>map ; M: hashtable make-slot-descriptions - call-next-method [ [ key-string>> ] compare ] sort ; + call-next-method [ key-string>> ] sort-with ; : ( model -- table ) [ make-slot-descriptions ] inspector-renderer diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 0e150ef07a..66bc277ef7 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -14,7 +14,7 @@ IN: vocabs.prettyprint > ] compare ] sort >vector + [ name>> ] sort-with >vector [ dup empty? not ] [ dup largest-class [ over delete-nth ] dip ] produce nip ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 312ddcd9be..b8258b239b 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -160,8 +160,8 @@ PRIVATE> : inv-sort-with ( seq quot -- sortedseq ) [ compare invert-comparison ] curry sort ; inline -: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ; +: sort-keys ( seq -- sortedseq ) [ first ] sort-with ; -: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; +: sort-values ( seq -- sortedseq ) [ second ] sort-with ; : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index f6f4f4825a..86a8354071 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -7,7 +7,7 @@ IN: source-files.errors TUPLE: source-file-error error asset file line# ; : sort-errors ( errors -- alist ) - [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; : group-by-source-file ( errors -- assoc ) H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index f47eb7010c..6934d3bbd9 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -10,7 +10,7 @@ MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ; +: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 6a52d02009..2c51d41aa0 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -59,7 +59,7 @@ TUPLE: paste < entity annotations ; : pastes ( -- pastes ) f select-tuples - [ [ date>> ] compare ] sort + [ date>> ] sort-with reverse ; TUPLE: annotation < entity parent ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 12b7ccda24..8ada4be638 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -56,7 +56,7 @@ posting "POSTINGS" : blogroll ( -- seq ) f select-tuples - [ [ name>> ] compare ] sort ; + [ name>> ] sort-with ; : postings ( -- seq ) posting new select-tuples diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 5689f23d4e..118f92061b 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -307,7 +307,7 @@ M: revision feed-entry-url id>> revision-url ; [ f
select-tuples - [ [ title>> ] compare ] sort + [ title>> ] sort-with "articles" set-value ] >>init From 2a6045110714ed39776570ac93079f30bca54888 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:10:58 -0500 Subject: [PATCH 6/9] [ [ ... ] compare invert-comparison ] sort => [ ... ] inv-sort-with --- extra/webapps/blogs/blogs.factor | 2 +- extra/webapps/planet/planet.factor | 4 ++-- extra/webapps/wiki/wiki.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index c16450bb25..f098bb9f09 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -83,7 +83,7 @@ M: comment entity-url >>comments ; : reverse-chronological-order ( seq -- sorted ) - [ [ date>> ] compare invert-comparison ] sort ; + [ date>> ] inv-sort-with ; : validate-author ( -- ) { { "author" [ v-username ] } } validate-params ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 8ada4be638..eb51acbe1a 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -60,7 +60,7 @@ posting "POSTINGS" : postings ( -- seq ) posting new select-tuples - [ [ date>> ] compare invert-comparison ] sort ; + [ date>> ] inv-sort-with ; : ( -- action ) @@ -99,7 +99,7 @@ posting "POSTINGS" [ '[ _ ] map ] 2map concat ; : sort-entries ( entries -- entries' ) - [ [ date>> ] compare invert-comparison ] sort ; + [ date>> ] inv-sort-with ; : update-cached-postings ( -- ) blogroll fetch-blogroll sort-entries 8 short head [ diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 118f92061b..f3a3784465 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -66,7 +66,7 @@ M: revision feed-entry-date date>> ; M: revision feed-entry-url id>> revision-url ; : reverse-chronological-order ( seq -- sorted ) - [ [ date>> ] compare invert-comparison ] sort ; + [ date>> ] inv-sort-with ; : ( id -- revision ) revision new swap >>id ; From a2fe9f1952f882b1ee2a227af229d56e1e1eb5d3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:13:59 -0500 Subject: [PATCH 7/9] [ [ ... ] bi@ <=> ] sort => [ ... ] sort-with --- basis/alien/fortran/fortran.factor | 2 +- extra/gpu/render/render.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 54b799f675..15840dfd66 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -365,7 +365,7 @@ M: character-type () ] bi* ; : (fortran-in-shuffle) ( ret par -- seq ) - [ [ second ] bi@ <=> ] sort append ; + [ second ] sort-with append ; : (fortran-out-shuffle) ( ret par -- seq ) append ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 35e137a235..2f920645ed 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -422,7 +422,7 @@ SYNTAX: UNIFORM-TUPLE: [ [ length ] [ >int-array ] bi glDrawBuffers ] if ; : bind-named-output-attachments ( program-instance framebuffer attachments -- ) - rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map + rot '[ first _ swap output-index ] sort-with [ second ] map bind-unnamed-output-attachments ; : bind-output-attachments ( program-instance framebuffer attachments -- ) From 97a515c04e39018e96bcd468e9d1eca2eb172c49 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:14:56 -0500 Subject: [PATCH 8/9] [ [ ... ] bi@ >=< ] sort => [ ... ] inv-sort-with --- extra/pair-methods/pair-methods.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor index d44d5bce78..131f9f5465 100644 --- a/extra/pair-methods/pair-methods.factor +++ b/extra/pair-methods/pair-methods.factor @@ -21,7 +21,7 @@ ERROR: no-pair-method a b generic ; : sorted-pair-methods ( word -- alist ) "pair-generic-methods" word-prop >alist - [ [ first method-sort-key ] bi@ >=< ] sort ; + [ first method-sort-key ] inv-sort-with ; : pair-generic-definition ( word -- def ) [ sorted-pair-methods [ first2 pair-method-cond ] map ] From f5edb8629f4919452384459a5847a3a0a56df5a6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 2 Aug 2009 20:17:25 -0500 Subject: [PATCH 9/9] one last sort-with-able straggler in fuel.xref --- extra/fuel/xref/xref.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 86aa215e21..cfd036e625 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -23,7 +23,7 @@ IN: fuel.xref dup dup >vocab-link where normalize-loc 4array ; : sort-xrefs ( seq -- seq' ) - [ [ first ] dip first <=> ] sort ; + [ first ] sort-with ; : format-xrefs ( seq -- seq' ) [ word? ] filter [ word>xref ] map ;