diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index ddefff35bb..572d8a5227 100644 --- a/basis/base64/base64-tests.factor +++ b/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 diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index c51d871bb5..47147fa306 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces sequences strings io.crlf ; IN: base64 +ERROR: malformed-base64 ; + ch swap 6 shift bitor ] reduce 3 >be ] [ [ CHAR: = = ] count ] bi head-slice* diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 2730340bfc..c4aa47d383 100755 --- a/basis/db/queries/queries.factor +++ b/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% ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 50d7f044d1..d4a58fa4fc 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/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 diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 63b55729fb..666e051088 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/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 ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 422efbd188..5a2a8974e7 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/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 -- ) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 1de3912f28..8be486cb1a 100644 --- a/basis/ui/ui.factor +++ b/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 [ no-window ] unless ; +: window ( handle -- world ) windows get-global at ; : 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 ( -- ) \ No newline at end of file +HOOK: beep ui-backend ( -- ) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 9619ae0bee..8085907bef 100644 --- a/basis/x11/windows/windows.factor +++ b/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" - 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 ; diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f7cd10a0e9..f787befc31 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/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 advance dup previous { +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + 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 ) - skip-whitespace +: take-define-identifier ( sequence-parser -- string ) + 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 -- ) - skip-whitespace take-rest swap elifs>> push ; +: handle-elif ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elifs>> push ; -: handle-else ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap elses>> push ; +: handle-else ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elses>> push ; -: handle-pragma ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap pragmas>> push ; +: handle-pragma ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap pragmas>> push ; -: handle-include-next ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap include-nexts>> push ; +: handle-include-next ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap include-nexts>> push ; -: handle-error ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap errors>> push ; +: handle-error ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap errors>> push ; ! nip take-rest throw ; -: handle-warning ( preprocessor-state state-parser -- ) - skip-whitespace +: handle-warning ( preprocessor-state sequence-parser -- ) + 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 -- ) - skip-whitespace dup current CHAR: # = +: preprocess-line ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments dup current CHAR: # = [ parse-directive-line ] [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ; : preprocess-lines ( preprocessor-state -- ) readln - [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] + [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] [ drop ] if* ; ERROR: include-nested-too-deeply ; diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 61315a4925..d95c79dd88 100644 --- a/extra/html/parser/parser.factor +++ b/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> diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor deleted file mode 100644 index c8a8a95892..0000000000 --- a/extra/html/parser/state/state-tests.factor +++ /dev/null @@ -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 } [ current 3 = ] take-until ] unit-test - -[ { 1 2 } ] -[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test - -[ "ab" ] -[ "abcd" "ab" take-sequence ] unit-test - -[ f ] -[ "abcd" "lol" take-sequence ] unit-test - -[ "ab" ] -[ - "abcd" - [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi -] unit-test - -[ "" ] -[ "abcd" "" take-sequence ] unit-test - -[ "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 - -[ "" ] -[ "" take-rest ] unit-test - -[ "" ] -[ "abc" dup "abc" take-sequence drop take-rest ] unit-test - -[ f ] -[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor deleted file mode 100644 index 2bcd08be5f..0000000000 --- a/extra/html/parser/state/state.factor +++ /dev/null @@ -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 ; - -: ( 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 - -: ( 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 - sequence sequence= [ - sequence - state-parser [ sequence length + ] change-n drop - ] [ - f - ] if ; - -:: take-until-sequence ( state-parser sequence -- sequence' ) - sequence length :> 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 -- ) - [ ] 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 ; diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 7abd2fcdf7..afd63daf6b 100644 --- a/extra/html/parser/utils/utils.factor +++ b/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 -combinators.short-circuit quoting ; +quotations sequences splitting strings quoting +combinators.short-circuit ; IN: html.parser.utils : trim1 ( seq ch -- newseq ) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index feb110fab8..c43559a630 100644 --- a/extra/id3/id3-docs.factor +++ b/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 } - { "album/f" "string or f" } + { "id3" id3 } + { "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 } - { "artist/f" "string or f" } + { "id3" id3 } + { "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 } - { "comment/f" "string or f" } + { "id3" id3 } + { "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 } - { "genre/f" "string or f" } + { "id3" id3 } + { "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 } - { "title/f" "string or f" } + { "id3" id3 } + { "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 } - { "year/f" "string or f" } + { "id3" id3 } + { "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 } "." } ; diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index a8f35e582c..9bb7558077 100644 --- a/extra/id3/id3-tests.factor +++ b/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 diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5076a4a8ab..a742a1f08d 100644 --- a/extra/id3/id3.factor +++ b/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 ( -- object ) id3v1-info new ; inline - -: ( header frames -- object ) - [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ; +: ( -- id3 ) + id3 new + H{ } clone >>frames ; inline :
( -- object ) header new ; inline : ( -- object ) frame new ; inline -: id3v2? ( mmap -- ? ) "ID3" head? ; inline +: id3v2? ( seq -- ? ) "ID3" head? ; inline -: id3v1? ( mmap -- ? ) - { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline +CONSTANT: id3v1-length 128 +CONSTANT: id3v1-offset 128 +CONSTANT: id3v1+-length 227 +CONSTANT: id3v1+-offset $[ 128 227 + ] -: id3v1-frame ( string key -- frame ) - - swap >>frame-id - swap >>data ; inline +: id3v1? ( seq -- ? ) + { + [ length id3v1-offset >= ] + [ 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 [ + + swap >>tag + swap >>data + ] [ + 2drop f + ] if ; inline + +: id3v1>frames ( id3v1 -- seq ) [ { - [ title>> "TIT2" id3v1-frame ] - [ artist>> "TPE1" id3v1-frame ] - [ album>> "TALB" id3v1-frame ] - [ year>> "TYER" id3v1-frame ] - [ comment>> "COMM" id3v1-frame ] - [ genre>> "TCON" id3v1-frame ] + [ title>> "TIT2" pair>frame ] + [ artist>> "TPE1" pair>frame ] + [ album>> "TALB" pair>frame ] + [ year>> "TYER" pair>frame ] + [ comment>> "COMM" pair>frame ] + [ genre>> "TCON" pair>frame ] } cleave - ] output>array f swap ; 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 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 ) [ ] dip { - [ 4 head-slice decode-text >>frame-id ] - [ [ 4 8 ] dip subseq >28bitword >>size ] + [ 4 head-slice decode-text >>tag ] + [ [ 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 ) - dup 4 head-slice valid-frame-id? +: read-frame ( seq -- frame/f ) + 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 ) - [ dup read-frame dup ] - [ [ remove-frame ] keep ] - produce 2nip ; inline +: frames>assoc ( seq -- assoc ) + [ [ tag>> ] keep ] H{ } map>assoc ; 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 ) [
] dip { [ [ 3 5 ] dip >array >>version ] [ [ 5 ] dip nth >>flags ] - [ [ 6 10 ] dip >28bitword >>size ] + [ [ 6 10 ] dip seq>synchsafe >>size ] } cleave ; inline -: read-v2-tag-data ( seq -- id3v2-info ) - 10 cut-slice - [ read-v2-header ] - [ read-frames ] bi* ; inline - -: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline +: merge-frames ( id3 assoc -- id3 ) + [ dup frames>> ] dip update ; inline -: (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip +: merge-id3v1 ( id3 -- id3 ) + 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 ) - skip-to-v1-data (read-v1-tag-data) ; inline +: read-v1-tags ( id3 seq -- id3 ) + 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 ) [ + [ ] dip { - { [ dup id3v2? ] [ read-v2-tag-data ] } - { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] } - [ drop f ] - } cond + [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v2? [ read-v2-tags ] [ drop ] if ] + } 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 ) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor new file mode 100644 index 0000000000..3b2fcad5eb --- /dev/null +++ b/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 } { 3 4 } take-until-sequence ] unit-test + +[ f "aaaa" ] +[ + "aaaa" + [ "b" take-until-sequence ] [ take-rest ] bi +] unit-test + +[ 6 ] +[ + " foo " [ skip-whitespace n>> ] parse-sequence +] unit-test + +[ { 1 2 } ] +[ { 1 2 3 } [ current 3 = ] take-until ] unit-test + +[ "ab" ] +[ "abcd" "ab" take-sequence ] unit-test + +[ f ] +[ "abcd" "lol" take-sequence ] unit-test + +[ "ab" ] +[ + "abcd" + [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi +] unit-test + +[ "" ] +[ "abcd" "" take-sequence ] unit-test + +[ "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 + +[ "" ] +[ "" take-rest ] unit-test + +[ "" ] +[ "abc" dup "abc" take-sequence drop take-rest ] unit-test + +[ f ] +[ "abc" "abcdefg" take-sequence ] unit-test + +[ "1234" ] +[ "1234f" take-integer ] unit-test + +[ "yes" ] +[ + "yes1234f" + [ take-integer drop ] [ "yes" take-sequence ] bi +] unit-test + +[ f ] [ "" 4 take-n ] unit-test +[ "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 diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor new file mode 100644 index 0000000000..4f57a7ccae --- /dev/null +++ b/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 -- 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 + +: ( 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 + 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 + 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 -- ) + [ ] 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 ; diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor index ad46abdad3..b26797f8d5 100644 --- a/extra/spider/unique-deque/unique-deque.factor +++ b/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