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

basis/base64/base64-tests.factor

@@ -23,5 +23,8 @@ IN: base64.tests
     ascii encode >base64-lines >string
 ] unit-test
 
+[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
+[ malformed-base64? ] must-fail-with
+
 \ >base64 must-infer
 \ base64> must-infer

basis/base64/base64.factor

@@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
 sequences strings io.crlf ;
 IN: base64
 
+ERROR: malformed-base64 ;
+
 <PRIVATE
 
 : read1-ignoring ( ignoring -- ch )
@@ -25,7 +27,7 @@ IN: base64
         f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
         22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
         40 41 42 43 44 45 46 47 48 49 50 51
-    } nth ; inline
+    } nth [ malformed-base64 ] unless* ; inline
 
 SYMBOL: column
 
@@ -48,8 +50,6 @@ SYMBOL: column
     [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
     [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 
-ERROR: malformed-base64 ;
-
 : decode4 ( seq -- )
     [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
     [ [ CHAR: = = ] count ] bi head-slice*

basis/db/queries/queries.factor

@@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
 strings math.parser math.intervals combinators math.bitwise
 nmake db db.tuples db.types classes words shuffle arrays
 destructors continuations db.tuples.private prettyprint
-db.private ;
+db.private byte-arrays ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
@@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
         [ " or " 0% ] [ dupd where ] interleave drop
     ] in-parens ;
 
+M: byte-array where ( spec obj -- )
+    over column-name>> 0% " = " 0% bind# ;
+
 M: NULL where ( spec obj -- )
     drop column-name>> 0% " is NULL" 0% ;
 

basis/db/tuples/tuples-tests.factor

@@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO"
 
 [ test-compound-primary-key ] test-sqlite
 [ test-compound-primary-key ] test-postgresql
+
+
+TUPLE: example id data ;
+
+example "EXAMPLE"
+{
+    { "id" "ID" +db-assigned-id+ }
+    { "data" "DATA" BLOB }
+} define-persistent
+
+: test-blob-select ( -- )
+    example ensure-table
+    [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
+    [
+        T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
+    ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
+
+[ test-blob-select ] test-sqlite
+[ test-blob-select ] test-postgresql

basis/tools/hexdump/hexdump.factor

@@ -16,10 +16,11 @@ IN: tools.hexdump
     16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
 
 : >hex-digit ( digit -- str )
-    >hex 2 CHAR: 0 pad-head " " append ;
+    >hex 2 CHAR: 0 pad-head ;
 
 : >hex-digits ( bytes -- str )
-    [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
+    [ >hex-digit " " append ] { } map-as concat
+    48 CHAR: \s pad-tail ;
 
 : >ascii ( bytes -- str )
     [ [ printable? ] keep CHAR: . ? ] "" map-as ;

basis/ui/backend/x11/x11.factor

@@ -224,6 +224,10 @@ M: x-clipboard paste-clipboard
     [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
     utf8 encode dup length XChangeProperty drop ;
 
+: set-class ( dpy window -- )
+    XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor"
+    utf8 encode dup length XChangeProperty drop ;
+
 M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap
     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
@@ -242,11 +246,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
 
 M: x11-ui-backend (open-window) ( world -- )
     dup gadget-window
-    handle>> window>> dup set-closable map-window ;
+    handle>> window>>
+    [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
 
 M: x11-ui-backend raise-window* ( world -- )
     handle>> [
-        dpy get swap window>> XRaiseWindow drop
+        dpy get swap window>>
+        [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+        [ XRaiseWindow drop ]
+        2bi
     ] when* ;
 
 M: x11-handle select-gl-context ( handle -- )

basis/ui/ui.factor

@@ -12,10 +12,7 @@ IN: ui
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
 
-ERROR: no-window handle ;
+: window ( handle -- world ) windows get-global at ;
-
-: window ( handle -- world )
-    windows get-global ?at [ no-window ] unless ;
 
 : window-focus ( handle -- gadget ) window world-focus ;
 
@@ -199,4 +196,4 @@ M: object close-window
 : with-ui ( quot -- )
     ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
 
-HOOK: beep ui-backend ( -- )
+HOOK: beep ui-backend ( -- )

basis/x11/windows/windows.factor

@@ -6,10 +6,10 @@ arrays fry ;
 IN: x11.windows
 
 : create-window-mask ( -- n )
-    { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+    { CWColormap CWEventMask } flags ;
 
 : create-colormap ( visinfo -- colormap )
-    dpy get root get rot XVisualInfo-visual AllocNone
+    [ dpy get root get ] dip XVisualInfo-visual AllocNone
     XCreateColormap ;
 
 : event-mask ( -- n )
@@ -29,8 +29,6 @@ IN: x11.windows
 
 : window-attributes ( visinfo -- attributes )
     "XSetWindowAttributes" <c-object>
-    0 over set-XSetWindowAttributes-background_pixel
-    0 over set-XSetWindowAttributes-border_pixel
     [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
     event-mask over set-XSetWindowAttributes-event_mask ;
 

extra/c/preprocessor/preprocessor.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: html.parser.state io io.encodings.utf8 io.files
+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
@@ -41,7 +41,7 @@ ifs elifs elses ;
 
 DEFER: preprocess-file
 
-ERROR: unknown-c-preprocessor state-parser name ;
+ERROR: unknown-c-preprocessor sequence-parser name ;
 
 ERROR: bad-include-line line ;
 
@@ -69,8 +69,16 @@ ERROR: header-file-missing path ;
         drop
     ] if ;
 
-: handle-include ( preprocessor-state state-parser -- )
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
-    skip-whitespace advance dup previous {
+    skip-whitespace
+    {
+        { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+        { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+        [ ]
+    } cond ;
+
+: handle-include ( preprocessor-state sequence-parser -- )
+    skip-whitespace/comments advance dup previous {
         { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
         { CHAR: " [ CHAR: " take-until-object read-local-include ] }
         [ bad-include-line ]
@@ -81,58 +89,58 @@ ERROR: header-file-missing path ;
 
 : readlns ( -- string ) [ (readlns) ] { } make concat ;
 
-: take-define-identifier ( state-parser -- string )
+: take-define-identifier ( sequence-parser -- string )
-    skip-whitespace
+    skip-whitespace/comments
     [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
 
-: handle-define ( preprocessor-state state-parser -- )
+: handle-define ( preprocessor-state sequence-parser -- )
     [ take-define-identifier ]
-    [ skip-whitespace take-rest ] bi 
+    [ skip-whitespace/comments take-rest ] bi 
     "\\" ?tail [ readlns append ] when
     spin symbol-table>> set-at ;
 
-: handle-undef ( preprocessor-state state-parser -- )
+: handle-undef ( preprocessor-state sequence-parser -- )
     take-token swap symbol-table>> delete-at ;
 
-: handle-ifdef ( preprocessor-state state-parser -- )
+: handle-ifdef ( preprocessor-state sequence-parser -- )
     [ [ 1 + ] change-ifdef-nesting ] dip
     take-token over symbol-table>> key?
     [ drop ] [ t >>processing-disabled? drop ] if ;
 
-: handle-ifndef ( preprocessor-state state-parser -- )
+: handle-ifndef ( preprocessor-state sequence-parser -- )
     [ [ 1 + ] change-ifdef-nesting ] dip
     take-token over symbol-table>> key?
     [ t >>processing-disabled? drop ]
     [ drop ] if ; 
 
-: handle-endif ( preprocessor-state state-parser -- )
+: handle-endif ( preprocessor-state sequence-parser -- )
     drop [ 1 - ] change-ifdef-nesting drop ;
 
-: handle-if ( preprocessor-state state-parser -- )
+: handle-if ( preprocessor-state sequence-parser -- )
     [ [ 1 + ] change-ifdef-nesting ] dip
-    skip-whitespace take-rest swap ifs>> push ;
+    skip-whitespace/comments take-rest swap ifs>> push ;
 
-: handle-elif ( preprocessor-state state-parser -- )
+: handle-elif ( preprocessor-state sequence-parser -- )
-    skip-whitespace take-rest swap elifs>> push ;
+    skip-whitespace/comments take-rest swap elifs>> push ;
 
-: handle-else ( preprocessor-state state-parser -- )
+: handle-else ( preprocessor-state sequence-parser -- )
-    skip-whitespace take-rest swap elses>> push ;
+    skip-whitespace/comments take-rest swap elses>> push ;
 
-: handle-pragma ( preprocessor-state state-parser -- )
+: handle-pragma ( preprocessor-state sequence-parser -- )
-    skip-whitespace take-rest swap pragmas>> push ;
+    skip-whitespace/comments take-rest swap pragmas>> push ;
 
-: handle-include-next ( preprocessor-state state-parser -- )
+: handle-include-next ( preprocessor-state sequence-parser -- )
-    skip-whitespace take-rest swap include-nexts>> push ;
+    skip-whitespace/comments take-rest swap include-nexts>> push ;
 
-: handle-error ( preprocessor-state state-parser -- )
+: handle-error ( preprocessor-state sequence-parser -- )
-    skip-whitespace take-rest swap errors>> push ;
+    skip-whitespace/comments take-rest swap errors>> push ;
     ! nip take-rest throw ;
 
-: handle-warning ( preprocessor-state state-parser -- )
+: handle-warning ( preprocessor-state sequence-parser -- )
-    skip-whitespace
+    skip-whitespace/comments
     take-rest swap warnings>> push ;
 
-: parse-directive ( preprocessor-state state-parser string -- )
+: parse-directive ( preprocessor-state sequence-parser string -- )
     {
         { "warning" [ handle-warning ] }
         { "error" [ handle-error ] }
@@ -150,7 +158,7 @@ ERROR: header-file-missing path ;
         [ unknown-c-preprocessor ]
     } case ;
 
-: parse-directive-line ( preprocessor-state state-parser -- )
+: parse-directive-line ( preprocessor-state sequence-parser -- )
     advance dup take-token
     pick processing-disabled?>> [
         "endif" = [
@@ -162,14 +170,14 @@ ERROR: header-file-missing path ;
         parse-directive
     ] if ;
 
-: preprocess-line ( preprocessor-state state-parser -- )
+: preprocess-line ( preprocessor-state sequence-parser -- )
-    skip-whitespace dup current CHAR: # =
+    skip-whitespace/comments dup current CHAR: # =
     [ parse-directive-line ]
     [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
 
 : preprocess-lines ( preprocessor-state -- )
     readln 
-    [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+    [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
     [ drop ] if* ;
 
 ERROR: include-nested-too-deeply ;

extra/html/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
+USING: accessors arrays hashtables sequence-parser
 html.parser.utils kernel namespaces sequences
 unicode.case unicode.categories combinators.short-circuit
 quoting fry ;
@@ -37,89 +37,89 @@ SYMBOL: tagstack
         swap >>name
         swap >>text ; inline
 
-: (read-quote) ( state-parser ch -- string )
+: (read-quote) ( sequence-parser ch -- string )
     '[ [ current _ = ] take-until ] [ advance drop ] bi ;
 
-: read-single-quote ( state-parser -- string )
+: read-single-quote ( sequence-parser -- string )
     CHAR: ' (read-quote) ;
 
-: read-double-quote ( state-parser -- string )
+: read-double-quote ( sequence-parser -- string )
     CHAR: " (read-quote) ;
 
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
     dup get+increment CHAR: ' =
     [ read-single-quote ] [ read-double-quote ] if ;
 
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
     skip-whitespace
     [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
 
-: read-token ( state-parser -- string )
+: read-token ( sequence-parser -- string )
     [ current blank? ] take-until ;
 
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
     skip-whitespace
     dup current quote? [ read-quote ] [ read-token ] if
     [ blank? ] trim ;
 
-: read-comment ( state-parser -- )
+: read-comment ( sequence-parser -- )
     "-->" take-until-sequence comment new-tag push-tag ;
 
-: read-dtd ( state-parser -- )
+: read-dtd ( sequence-parser -- )
     ">" take-until-sequence dtd new-tag push-tag ;
 
-: read-bang ( state-parser -- )
+: read-bang ( sequence-parser -- )
     advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
     [ advance advance read-comment ] [ read-dtd ] if ;
 
-: read-tag ( state-parser -- string )
+: read-tag ( sequence-parser -- string )
     [ [ current "><" member? ] take-until ]
     [ dup current CHAR: < = [ advance ] unless drop ] bi ;
 
-: read-until-< ( state-parser -- string )
+: read-until-< ( sequence-parser -- string )
     [ current CHAR: < = ] take-until ;
 
-: parse-text ( state-parser -- )
+: parse-text ( sequence-parser -- )
     read-until-< [ text new-tag push-tag ] unless-empty ;
 
-: parse-key/value ( state-parser -- key value )
+: parse-key/value ( sequence-parser -- key value )
     [ read-key >lower ]
     [ skip-whitespace "=" take-sequence ]
     [ swap [ read-value ] [ drop dup ] if ] tri ;
 
-: (parse-attributes) ( state-parser -- )
+: (parse-attributes) ( sequence-parser -- )
     skip-whitespace
-    dup state-parse-end? [
+    dup sequence-parse-end? [
         drop
     ] [
         [ parse-key/value swap set ] [ (parse-attributes) ] bi
     ] if ;
 
-: parse-attributes ( state-parser -- hashtable )
+: parse-attributes ( sequence-parser -- hashtable )
     [ (parse-attributes) ] H{ } make-assoc ;
 
 : (parse-tag) ( string -- string' hashtable )
     [
         [ read-token >lower ] [ parse-attributes ] bi
-    ] state-parse ;
+    ] parse-sequence ;
 
-: read-< ( state-parser -- string/f )
+: read-< ( sequence-parser -- string/f )
     advance dup current [
         CHAR: ! = [ read-bang f ] [ read-tag ] if
     ] [
         drop f
     ] if* ;
 
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
     read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
 
-: (parse-html) ( state-parser -- )
+: (parse-html) ( sequence-parser -- )
     dup peek-next [
         [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
     ] [ drop ] if ;
 
 : tag-parse ( quot -- vector )
-    V{ } clone tagstack [ state-parse ] with-variable ; inline
+    V{ } clone tagstack [ parse-sequence ] with-variable ; inline
 
 PRIVATE>
 

extra/html/parser/state/state-tests.factor

@@ -1,104 +0,0 @@
-USING: tools.test html.parser.state ascii kernel accessors ;
-IN: html.parser.state.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] state-parse ] unit-test
-
-[ "hi" " how are you?" ]
-[
-    "hi how are you?"
-    [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
-] unit-test
-
-[ "foo" ";bar" ]
-[
-    "foo;bar" [
-        [ CHAR: ; take-until-object ] [ take-rest ] bi
-    ] state-parse
-] unit-test
-
-[ "foo " " bar" ]
-[
-    "foo and bar" [
-        [ "and" take-until-sequence ] [ take-rest ] bi 
-    ] state-parse
-] unit-test
-
-[ 6 ]
-[
-    "      foo   " [ skip-whitespace n>> ] state-parse
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ "ab" ]
-[ "abcd" <state-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <state-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
-    "abcd" <state-parser>
-    [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <state-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[
-    "\"abc\" asdf" <state-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
-    "\"abc\\\"def\" asdf" <state-parser>
-    CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
-    "\"abc\" asdf" <state-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ]
-    [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
-    "\"abc asdf" <state-parser>
-    CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
-    "\"abc asdf" <state-parser>
-    [ CHAR: \ CHAR: " take-quoted-string drop ]
-    [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <state-parser> take-token ] unit-test
-
-[ f ]
-[ "" <state-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
-[ "" ]
-[ "" <state-parser> take-rest ] unit-test
-
-[ "" ]
-[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test

extra/html/parser/state/state.factor

@@ -1,127 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! 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 ;
-
-IN: html.parser.state
-
-TUPLE: state-parser sequence n ;
-
-: <state-parser> ( sequence -- state-parser )
-    state-parser new
-        swap >>sequence
-        0 >>n ;
-
-: offset  ( state-parser offset -- char/f )
-    swap
-    [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( state-parser -- char/f ) 0 offset ; inline
-
-: previous ( state-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( state-parser -- char/f ) 1 offset ; inline
-
-: advance ( state-parser -- state-parser )
-    [ 1 + ] change-n ; inline
-
-: advance* ( state-parser -- )
-    advance drop ; inline
-
-: get+increment ( state-parser -- char/f )
-    [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( state-parser quot: ( obj -- ? ) -- )
-    state-parser current [
-        state-parser quot call [ state-parser advance quot skip-until ] unless
-    ] when ; inline recursive
-
-: state-parse-end? ( state-parser -- ? ) current not ;
-
-: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
-    over state-parse-end? [
-        2drop f
-    ] [
-        [ drop n>> ]
-        [ skip-until ]
-        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
-    ] if ; inline
-
-: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
-    [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
-    3dup {
-        [ 2drop 0 < ]
-        [ [ drop ] 2dip length > ]
-        [ drop > ]
-    } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( state-parser sequence -- obj/f )
-    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
-    <safe-slice> sequence sequence= [
-        sequence
-        state-parser [ sequence length + ] change-n drop
-    ] [
-        f
-    ] if ;
-
-:: take-until-sequence ( state-parser sequence -- sequence' )
-    sequence length <growing-circular> :> growing
-    state-parser
-    [
-        current growing push-growing-circular
-        sequence growing sequence=
-    ] take-until :> found
-    found dup length
-    growing length 1- - head
-    state-parser advance drop ;
-    
-: skip-whitespace ( state-parser -- state-parser )
-    [ [ current blank? not ] take-until drop ] keep ;
-
-: take-rest-slice ( state-parser -- sequence/f )
-    [ sequence>> ] [ n>> ] bi
-    2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( state-parser -- sequence )
-    [ take-rest-slice ] [ sequence>> like ] bi ;
-
-: take-until-object ( state-parser obj -- sequence )
-    '[ current _ = ] take-until ;
-
-: state-parse ( sequence quot -- )
-    [ <state-parser> ] dip call ; inline
-
-:: take-quoted-string ( state-parser escape-char quote-char -- string )
-    state-parser n>> :> start-n
-    state-parser advance
-    [
-        {
-            [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
-            [ current quote-char = not ]
-        } 1||
-    ] take-while :> string
-    state-parser current quote-char = [
-        state-parser advance* string
-    ] [
-        start-n state-parser (>>n) f
-    ] if ;
-
-: (take-token) ( state-parser -- string )
-    skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( state-parser escape-char quote-char -- string/f )
-    state-parser skip-whitespace
-    dup current {
-        { quote-char [ escape-char quote-char take-quoted-string ] }
-        { f [ drop f ] }
-        [ drop (take-token) ]
-    } case ;
-
-: take-token ( state-parser -- string/f )
-    CHAR: \ CHAR: " take-token* ;
-
-: write-full ( state-parser -- ) sequence>> write ;
-: write-rest ( state-parser -- ) take-rest write ;

extra/html/parser/utils/utils.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting html.parser.state strings
+quotations sequences splitting strings quoting
-combinators.short-circuit quoting ;
+combinators.short-circuit ;
 IN: html.parser.utils
 
 : trim1 ( seq ch -- newseq )

extra/id3/id3-docs.factor

@@ -7,7 +7,7 @@ IN: id3
 HELP: mp3>id3
 { $values 
     { "path" "a path string" } 
-    { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+    { "id3/f" "a tuple storing ID3v2 metadata or f" } }
     { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
         { $list
           { $link title }
@@ -22,49 +22,49 @@ HELP: mp3>id3
 
 HELP: album
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "album/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: artist
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "artist/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: comment
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "comment/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: genre
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "genre/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: title
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "title/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: year
 { $values
-    { "id3" id3v2-info }
+    { "id3" id3 }
-    { "year/f" "string or f" }
+    { "string/f" "string or f" }
 }
 { $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
 
 HELP: find-id3-frame
 { $values
-    { "id3" id3v2-info } { "name" string }
+    { "id3" id3 } { "name" string }
     { "obj/f" "object or f" }
 }
 { $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;

extra/id3/id3-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Tim Wawrzynczak
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 combinators ;
+USING: tools.test id3 combinators grouping id3.private
+sequences math ;
 IN: id3.tests
 
 : id3-params ( id3 -- title artist album year comment genre )
@@ -40,3 +41,6 @@ IN: id3.tests
    "Big Band"
 ] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
 
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test

extra/id3/id3.factor

@@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
 io.encodings.string io.encodings.utf16 assocs math.parser
 combinators.short-circuit fry namespaces combinators.smart
 splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search ;
+io.directories.search literals math.functions ;
 IN: id3
 
 <PRIVATE
@@ -37,58 +37,83 @@ CONSTANT: genres
         "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango" 
         "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul" 
         "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella" 
-        "Euro-House" "Dance Hall"
+        "Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
+        "Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
+        "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+        "Black Metal" "Crossover" "Contemporary Christian"
+        "Christian Rock"
     }
 
 TUPLE: header version flags size ;
 
-TUPLE: frame frame-id flags size data ;
+TUPLE: frame tag flags size data ;
 
-TUPLE: id3v2-info header frames ;
+TUPLE: id3 header frames
+title artist album year comment genre
+speed genre-name start-time end-time ;
 
-TUPLE: id3v1-info title artist album year comment genre ;
+: <id3> ( -- id3 )
-
+    id3 new
-: <id3v1-info> ( -- object ) id3v1-info new ; inline
+    H{ } clone >>frames ; inline
-
-: <id3v2-info> ( header frames -- object )
-    [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
 
 : <header> ( -- object ) header new ; inline
 
 : <frame> ( -- object ) frame new ; inline
 
-: id3v2? ( mmap -- ? ) "ID3" head? ; inline
+: id3v2? ( seq -- ? ) "ID3" head? ; inline
 
-: id3v1? ( mmap -- ? )
+CONSTANT: id3v1-length 128
-    { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
 
-: id3v1-frame ( string key -- frame )
+: id3v1? ( seq -- ? )
-    <frame>
+    {
-        swap >>frame-id
+        [ length id3v1-offset >= ]
-        swap >>data ; inline
+        [ id3v1-length tail-slice* "TAG" head? ]
+    } 1&& ; inline
 
-: id3v1>id3v2 ( id3v1 -- id3v2 )
+: id3v1+? ( seq -- ? )
+    {
+        [ length id3v1+-offset >= ]
+        [ id3v1+-length tail-slice* "TAG+" head? ]
+    } 1&& ; inline
+
+: pair>frame ( string key -- frame/f )
+    over [
+        <frame>
+            swap >>tag
+            swap >>data
+    ] [
+        2drop f
+    ] if ; inline
+
+: id3v1>frames ( id3v1 -- seq )
     [
         {
-            [ title>> "TIT2" id3v1-frame ]
+            [ title>> "TIT2" pair>frame ]
-            [ artist>> "TPE1" id3v1-frame ]
+            [ artist>> "TPE1" pair>frame ]
-            [ album>> "TALB" id3v1-frame ]
+            [ album>> "TALB" pair>frame ]
-            [ year>> "TYER" id3v1-frame ]
+            [ year>> "TYER" pair>frame ]
-            [ comment>> "COMM" id3v1-frame ]
+            [ comment>> "COMM" pair>frame ]
-            [ genre>> "TCON" id3v1-frame ]
+            [ genre>> "TCON" pair>frame ]
         } cleave
-    ] output>array f swap <id3v2-info> ; inline
+    ] output>array sift ;
 
-: >28bitword ( seq -- int )
+: seq>synchsafe ( seq -- n )
     0 [ [ 7 shift ] dip bitor ] reduce ; inline
 
+: synchsafe>seq ( n -- seq )
+    dup 1+ log2 1+ 7 / ceiling
+    [ [ -7 shift ] keep HEX: 7f bitand  ] replicate nip reverse ; inline
+
 : filter-text-data ( data -- filtered )
     [ printable? ] filter ; inline
 
-: valid-frame-id? ( id -- ? )
+: valid-tag? ( id -- ? )
     [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
 
-: read-frame-data ( frame mmap -- frame data )
+: read-frame-data ( frame seq -- frame data )
     [ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
 
 : decode-text ( string -- string' )
@@ -96,44 +121,48 @@ TUPLE: id3v1-info title artist album year comment genre ;
     { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
     utf16 ascii ? decode ; inline
 
-: (read-frame) ( mmap -- frame )
+: (read-frame) ( seq -- frame )
     [ <frame> ] dip
     {
-        [ 4 head-slice decode-text >>frame-id ]
+        [ 4 head-slice decode-text >>tag ]
-        [ [ 4 8 ] dip subseq >28bitword >>size ]
+        [ [ 4 8 ] dip subseq seq>synchsafe >>size ]
         [ [ 8 10 ] dip subseq >byte-array >>flags ]
         [ read-frame-data decode-text >>data ]
     } cleave ; inline
 
-: read-frame ( mmap -- frame/f )
+: read-frame ( seq -- frame/f )
-    dup 4 head-slice valid-frame-id?
+    dup 4 head-slice valid-tag?
     [ (read-frame) ] [ drop f ] if ; inline
 
-: remove-frame ( mmap frame -- mmap )
+: remove-frame ( seq frame -- seq )
     size>> 10 + tail-slice ; inline
 
-: read-frames ( mmap -- frames )
+: frames>assoc ( seq -- assoc )
-    [ dup read-frame dup ]
+    [ [ tag>> ] keep ] H{ } map>assoc ; inline
-    [ [ remove-frame ] keep ]
+
-    produce 2nip ; inline
+: read-frames ( seq -- assoc )
+    [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline
     
-: read-v2-header ( seq -- id3header )
+: read-v2-header ( seq -- header )
     [ <header> ] dip
     {
         [ [ 3 5 ] dip <slice> >array >>version ]
         [ [ 5 ] dip nth >>flags ]
-        [ [ 6 10 ] dip <slice> >28bitword >>size ]
+        [ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
     } cleave ; inline
 
-: read-v2-tag-data ( seq -- id3v2-info )
+: merge-frames ( id3 assoc -- id3 )
-    10 cut-slice
+    [ dup frames>> ] dip update ; inline
-    [ read-v2-header ]
-    [ read-frames ] bi* <id3v2-info> ; inline
-    
-: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
 
-: (read-v1-tag-data) ( seq -- mp3-file )
+: merge-id3v1 ( id3 -- id3 )
-    [ <id3v1-info> ] dip
+    dup id3v1>frames frames>assoc merge-frames ; inline
+
+: read-v2-tags ( id3 seq -- id3 )
+    10 cut-slice
+    [ read-v2-header >>header ]
+    [ read-frames frames>assoc merge-frames ] bi* ; inline
+    
+: extract-v1-tags ( id3 seq -- id3 )
     {
         [ 30 head-slice decode-text filter-text-data >>title ]
         [ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
@@ -143,8 +172,30 @@ TUPLE: id3v1-info title artist album year comment genre ;
         [ [ 124 ] dip nth number>string >>genre ]
     } cleave ; inline
 
-: read-v1-tag-data ( seq -- mp3-file )
+: read-v1-tags ( id3 seq -- id3 )
-    skip-to-v1-data (read-v1-tag-data) ; inline
+    id3v1-offset tail-slice* 3 tail-slice
+    extract-v1-tags ; inline
+
+: extract-v1+-tags ( id3 seq -- id3 )
+    {
+        [ 60 head-slice decode-text filter-text-data [ append ] change-title ]
+        [
+            [ 60 120 ] dip subseq decode-text filter-text-data
+            [ append ] change-artist
+        ]
+        [
+            [ 120 180 ] dip subseq decode-text filter-text-data
+            [ append ] change-album
+        ]
+        [ [ 180 ] dip nth >>speed ]
+        [ [ 181 211 ] dip subseq decode-text >>genre-name ]
+        [ [ 211 217 ] dip subseq decode-text >>start-time ]
+        [ [ 217 223 ] dip subseq decode-text >>end-time ]
+    } cleave ; inline
+
+: read-v1+-tags ( id3 seq -- id3 )
+    id3v1+-offset tail-slice* 4 tail-slice
+    extract-v1+-tags ; inline
 
 : parse-genre ( string -- n/f )
     dup "(" ?head-slice drop ")" ?tail-slice drop
@@ -154,34 +205,35 @@ TUPLE: id3v1-info title artist album year comment genre ;
         drop
     ] if ; inline
 
-: (mp3>id3) ( path -- id3v2-info/f )
+: (mp3>id3) ( path -- id3v2/f )
     [
+        [ <id3> ] dip
         {
-            { [ dup id3v2? ] [ read-v2-tag-data ] }
+            [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
-            { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
+            [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
-            [ drop f ]
+            [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
-        } cond
+        } cleave
     ] with-mapped-uchar-file ;
 
 PRIVATE>
 
-: mp3>id3 ( path -- id3v2-info/f )
+: mp3>id3 ( path -- id3/f )
     dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
 
 : find-id3-frame ( id3 name -- obj/f )
     swap frames>> at* [ data>> ] when ; inline
 
-: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline
 
-: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline
 
-: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline
 
-: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline
 
-: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline
 
-: genre ( id3 -- genre/f )
+: genre ( id3 -- string/f )
     "TCON" find-id3-frame parse-genre ; inline
 
 : find-mp3s ( path -- seq )

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

@@ -0,0 +1,191 @@
+USING: tools.test sequence-parser ascii kernel accessors ;
+IN: sequence-parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+    "hi how are you?"
+    [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+    "foo;bar" [
+        [ CHAR: ; take-until-object ] [ take-rest ] bi
+    ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+    "foo and bar" [
+        [ "and" take-until-sequence ] [ take-rest ] bi 
+    ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+    "foo and bar" [
+        [ "and" take-until-sequence ]
+        [ "and" take-sequence drop ]
+        [ take-rest ] tri
+    ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+    "foo and bar" [
+        [ "and" take-until-sequence* ]
+        [ take-rest ] bi
+    ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+    "aaaa" <sequence-parser>
+    [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+    "      foo   " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+    "abcd" <sequence-parser>
+    [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "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
+
+[ "" ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+    "yes1234f" <sequence-parser>
+    [ take-integer drop ] [ "yes" take-sequence ] bi 
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "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

extra/sequence-parser/sequence-parser.factor

@@ -0,0 +1,229 @@
+! 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 ;
+IN: sequence-parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+    sequence-parser new
+        swap >>sequence
+        0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+    sequence-parser n>> :> n
+    sequence-parser quot call [
+        n sequence-parser (>>n) f
+    ] unless* ; inline
+
+: offset  ( sequence-parser offset -- char/f )
+    swap
+    [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+    [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+    advance drop ; inline
+
+: get+increment ( sequence-parser -- char/f )
+    [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+    sequence-parser current [
+        sequence-parser quot call
+        [ sequence-parser advance quot skip-until ] unless
+    ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+    over sequence-parse-end? [
+        2drop f
+    ] [
+        [ drop n>> ]
+        [ skip-until ]
+        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+    ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+    [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+    3dup {
+        [ 2drop 0 < ]
+        [ [ drop ] 2dip length > ]
+        [ drop > ]
+    } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+    sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+    <safe-slice> sequence sequence= [
+        sequence
+        sequence-parser [ sequence length + ] change-n drop
+    ] [
+        f
+    ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+    take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+    sequence-parser n>> :> saved
+    sequence length <growing-circular> :> growing
+    sequence-parser
+    [
+        current growing push-growing-circular
+        sequence growing sequence=
+    ] take-until :> found
+    growing sequence sequence= [
+        found dup length
+        growing length 1- - head
+        sequence-parser [ growing length - 1 + ] change-n drop
+        ! sequence-parser advance drop
+    ] [
+        saved sequence-parser (>>n)
+        f
+    ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+    sequence-parser sequence take-until-sequence :> out
+    out [
+        sequence-parser [ sequence length + ] change-n drop
+    ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+    [ [ current blank? not ] take-until drop ] keep ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+    [ sequence>> ] [ n>> ] bi
+    2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+    [ take-rest-slice ] [ sequence>> like ] bi ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+    '[ current _ = ] take-until ;
+
+: 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 ;
+
+:: take-n ( sequence-parser n -- seq/f )
+    n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+        f
+    ] [
+        sequence-parser n>> dup n + sequence-parser sequence>> subseq
+        sequence-parser [ n + ] change-n drop
+    ] if ;
+
+: 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 ;
+
+: 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 ( state-parser -- string/f )
+    [
+        dup current c-identifier-begin? [
+            [ current c-identifier-ch? ] take-while
+        ] [
+            drop f
+        ] if
+    ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+    { length>=< <=> } sort-by ;
+
+: take-first-matching ( state-parser seq -- seq )
+    swap
+    '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+
+: take-longest ( state-parser seq -- seq )
+    sort-tokens take-first-matching ;
+
+: take-c-integer ( state-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 ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;

extra/spider/unique-deque/unique-deque.factor

@@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ;
 : pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
 
 : peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
+: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+    pick deque-empty? [ 3drop ] [
+        [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+        [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
+    ] if ; inline recursive