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

basis/alien/fortran/fortran.factor

@@ -365,7 +365,7 @@ M: character-type (<fortran-result>)
     ] bi* ;
 
 : (fortran-in-shuffle) ( ret par -- seq )
-    [ [ second ] bi@ <=> ] sort append ;
+    [ second ] sort-with append ;
 
 : (fortran-out-shuffle) ( ret par -- seq )
     append ;

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
 

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 )
     [

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 ;

basis/interval-maps/interval-maps.factor

@@ -46,7 +46,7 @@ PRIVATE>
     array>> [ value ] map ;
 
 : <interval-map> ( specification -- map )
-    all-intervals [ [ first second ] compare ] sort
+    all-intervals [ first second ] sort-with
     >intervals ensure-disjoint interval-map boa ;
 
 : <interval-set> ( specification -- map )

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 ;

basis/ui/gadgets/menus/menus.factor

@@ -65,7 +65,7 @@ M: ---- <menu-item>
 : <operations-menu> ( target hook -- menu )
     over object-operations
     [ primary-operation? ] partition
-    [ reverse ] [ [ [ command-name ] compare ] sort ] bi*
+    [ reverse ] [ [ command-name ] sort-with ] bi*
     { ---- } glue <commands-menu> ;
 
 : show-operations-menu ( gadget target hook -- )

basis/ui/tools/inspector/inspector.factor

@@ -57,7 +57,7 @@ M: object make-slot-descriptions
     make-mirror [ <slot-description> ] { } assoc>map ;
 
 M: hashtable make-slot-descriptions
-    call-next-method [ [ key-string>> ] compare ] sort ;
+    call-next-method [ key-string>> ] sort-with ;
 
 : <inspector-table> ( model -- table )
     [ make-slot-descriptions ] <arrow> inspector-renderer <table>

basis/vocabs/prettyprint/prettyprint.factor

@@ -14,7 +14,7 @@ IN: vocabs.prettyprint
 <PRIVATE
 
 : sort-vocabs ( seq -- seq' )
-    [ [ vocab-name ] compare ] sort ;
+    [ vocab-name ] sort-with ;
 
 : pprint-using ( seq -- )
     [ "syntax" vocab = not ] filter

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 <file-reader>. We use the lower-level form
     #! so that we can move io.encodings.binary to basis/.
     [ normalize-path (file-reader) ] dip checksum-stream ;

core/classes/algebra/algebra.factor

@@ -207,7 +207,7 @@ M: anonymous-complement (classes-intersect?)
     [ "Topological sort failed" throw ] unless* ;
 
 : sort-classes ( seq -- newseq )
-    [ [ name>> ] compare ] sort >vector
+    [ name>> ] sort-with >vector
     [ dup empty? not ]
     [ dup largest-class [ over delete-nth ] dip ]
     produce nip ;

core/combinators/combinators.factor

@@ -113,7 +113,7 @@ ERROR: no-case object ;
     ] if ;
 
 : <buckets> ( 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

core/generic/single/single.factor

@@ -145,7 +145,7 @@ GENERIC: compile-engine ( engine -- obj )
     default get <array> [ <enum> 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

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 )

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>
 <PRIVATE
 
 : (start) ( subseq seq n -- subseq seq ? )
-    pick length [
+    pick length iota [
         [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
     ] all? nip ; inline
 
 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 ;
 

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

core/sorting/sorting.factor

@@ -155,8 +155,13 @@ PRIVATE>
 
 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
 
-: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
+: sort-with ( seq quot -- sortedseq )
+    [ compare ] curry sort ; inline
+: inv-sort-with ( seq quot -- sortedseq )
+    [ compare invert-comparison ] curry sort ; inline
 
-: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
+: sort-keys ( seq -- sortedseq ) [ first ] sort-with ;
+
+: sort-values ( seq -- sortedseq ) [ second ] sort-with ;
 
 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;

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 ;

extra/c/lexer/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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      "
+    <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "asdfasdf" ] [
+    "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+    "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+    "//asdfasdf\nomg" <sequence-parser>
+    [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+    "omg" <sequence-parser>
+    [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+    "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+    "//asdf\neoieoei" <sequence-parser>
+    [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f ]
+[
+    "\"abc\" asdf" <sequence-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+    "\"abc\\\"def\" asdf" <sequence-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+    "\"abc\" asdf" <sequence-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+    "\"abc asdf" <sequence-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+    "\"abc asdf" <sequence-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
+

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 ;

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 )

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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

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 ;

extra/gpu/render/render.factor

@@ -73,7 +73,7 @@ TUPLE: multi-index-range
 C: <multi-index-range> 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 } ;
 
@@ -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 -- )

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 ]

extra/sequence-parser/sequence-parser-tests.factor

@@ -77,47 +77,6 @@ IN: sequence-parser.tests
 [ "cd" ]
 [ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
 
-[ f ]
-[
-    "\"abc\" asdf" <sequence-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
-    "\"abc\\\"def\" asdf" <sequence-parser>
-    CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
-    "\"abc\" asdf" <sequence-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ]
-    [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
-    "\"abc asdf" <sequence-parser>
-    CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
-    "\"abc asdf" <sequence-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ]
-    [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <sequence-parser> take-token ] unit-test
-
-[ f ]
-[ "" <sequence-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
 [ f ]
 [ "" <sequence-parser> take-rest ] unit-test
 
@@ -140,63 +99,6 @@ IN: sequence-parser.tests
 [ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
 [ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
 
-[ "asdfasdf" ] [
-    "/*asdfasdf*/" <sequence-parser> take-c-comment 
-] unit-test
-
-[ "k" ] [
-    "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
-    "//asdfasdf\nomg" <sequence-parser>
-    [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
-    "omg" <sequence-parser>
-    [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "/*asdfasdf" ] [
-    "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "asdf" "eoieoei" ] [
-    "//asdf\neoieoei" <sequence-parser>
-    [ take-c++-comment ] [ take-rest ] bi
-] unit-test
-
-[ f "33asdf" ]
-[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
-
-[ "asdf" ]
-[ "asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf" ]
-[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf400" ]
-[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
-
-[ "123" ]
-[ "123jjj" <sequence-parser> take-c-integer ] unit-test
-
-[ "123uLL" ]
-[ "123uLL" <sequence-parser> take-c-integer ] unit-test
-
-[ "123ull" ]
-[ "123ull" <sequence-parser> take-c-integer ] unit-test
-
-[ "123u" ]
-[ "123u" <sequence-parser> take-c-integer ] unit-test
-
-[ 36 ]
-[
-    "    //jofiejoe\n    //eoieow\n/*asdf*/\n      "
-    <sequence-parser> skip-whitespace/comments n>>
-] unit-test
-
 [ f ]
 [ "\n" <sequence-parser> take-integer ] unit-test
 

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
+USING: accessors circular combinators.short-circuit fry io
-unicode.case unicode.categories locals combinators.short-circuit
+kernel locals math math.order sequences sorting.functor
-make combinators io splitting math.parser math.ranges
+sorting.slots unicode.categories ;
-generalizations sorting.functor math.order sorting.slots ;
 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 -- )
     [ <sequence-parser> ] 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 ;

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 ;

extra/webapps/pastebin/pastebin.factor

@@ -59,7 +59,7 @@ TUPLE: paste < entity annotations ;
 
 : pastes ( -- pastes )
     f <paste> select-tuples
-    [ [ date>> ] compare ] sort
+    [ date>> ] sort-with
     reverse ;
 
 TUPLE: annotation < entity parent ;

extra/webapps/planet/planet.factor

@@ -56,11 +56,11 @@ posting "POSTINGS"
 
 : blogroll ( -- seq )
     f <blog> select-tuples
-    [ [ name>> ] compare ] sort ;
+    [ name>> ] sort-with ;
 
 : postings ( -- seq )
     posting new select-tuples
-    [ [ date>> ] compare invert-comparison ] sort ;
+    [ date>> ] inv-sort-with ;
 
 : <edit-blogroll-action> ( -- action )
     <page-action>
@@ -99,7 +99,7 @@ posting "POSTINGS"
     [ '[ _ <posting> ] 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 [

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 ;
 
 : <revision> ( id -- revision )
     revision new swap >>id ;
@@ -307,7 +307,7 @@ M: revision feed-entry-url id>> revision-url ;
 
         [
             f <article> select-tuples
-            [ [ title>> ] compare ] sort
+            [ title>> ] sort-with
             "articles" set-value
         ] >>init