diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 0187a6ce52..64b2cdb550 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -397,7 +397,7 @@ M: quotation ' [ { dictionary source-files builtins - update-map class<=-cache + update-map implementors-map class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache } [ dup get swap bootstrap-word set ] each diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6a3c1c35d5..e4e0db8609 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set +H{ } clone implementors-map set init-caches ! Vocabulary for slot accessors @@ -492,7 +493,8 @@ tuple "curry" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( obj quot -- curry )) define-declared "compose" "kernel" create tuple @@ -513,7 +515,8 @@ tuple "compose" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( quot1 quot2 -- compose )) define-declared ! Primitive words : make-primitive ( word vocab n -- ) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f94cc0ed37..5ee263469e 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -49,7 +49,7 @@ millis >r default-image-name "output-image" set-global -"math compiler help random tools ui ui.tools io handbook" "include" set-global +"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9fc4f6c4e7..1325fa65db 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -68,7 +68,10 @@ HELP: tuple-class { $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: update-map -{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; +{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; + +! HELP: implementors-map +! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ; HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index a03fed7fcb..7eaa6c0e12 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units kernel.private ; +compiler.units kernel.private sorting vocabs ; IN: classes.tests ! DEFER: bah @@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ; [ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test + +[ t ] [ + all-words [ class? ] filter + implementors-map get keys + [ natural-sort ] bi@ = +] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 9c0398cf61..0fef6de748 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions assocs kernel kernel.private slots.private namespaces sequences strings words vectors math -quotations combinators sorting effects graphs vocabs ; +quotations combinators sorting effects graphs vocabs sets ; IN: classes SYMBOL: class<=-cache @@ -27,24 +27,24 @@ SYMBOL: class-or-cache SYMBOL: update-map +SYMBOL: implementors-map + PREDICATE: class < word "class" word-prop ; PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; -: classes ( -- seq ) all-words [ class? ] filter ; +: classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; -: predicate-effect T{ effect f 1 { "?" } } ; - PREDICATE: predicate < word "predicating" word-prop >boolean ; : define-predicate ( class quot -- ) >r "predicate" word-prop first - r> predicate-effect define-declared ; + r> (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- ) M: word reset-class drop ; +GENERIC: implementors ( class/classes -- seq ) + ! update-map : class-uses ( class -- seq ) [ @@ -87,6 +89,16 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; +M: class implementors implementors-map get at keys ; + +M: sequence implementors [ implementors ] gather ; + +: implementors-map+ ( class -- ) + H{ } clone swap implementors-map get set-at ; + +: implementors-map- ( class -- ) + implementors-map get delete-at ; + : make-class-props ( superclass members participants metaclass -- assoc ) [ { @@ -99,7 +111,7 @@ M: word reset-class drop ; : (define-class) ( word props -- ) >r - dup class? [ dup new-class ] unless + dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless dup reset-class dup deferred? [ dup define-symbol ] when dup word-props @@ -139,6 +151,23 @@ GENERIC: update-methods ( class seq -- ) [ forget ] [ drop ] if ] [ 2drop ] if ; +: forget-methods ( class -- ) + [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; + +: forget-class ( class -- ) + class-usages [ + { + [ forget-predicate ] + [ forget-methods ] + [ implementors-map- ] + [ update-map- ] + [ reset-class ] + } cleave + ] each ; + +M: class forget* ( class -- ) + [ forget-class ] [ call-next-method ] bi ; + GENERIC: class ( object -- class ) : instance? ( obj class -- ? ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 8bcbe090b1..ca6949366a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel sequences namespaces assocs hashtables definitions kernel.private classes classes.private -classes.algebra quotations arrays vocabs effects combinators ; +classes.algebra quotations arrays vocabs effects combinators +sets ; IN: generic ! Method combination protocol @@ -94,8 +95,13 @@ M: method-body crossref? method-word-name f [ set-word-props ] keep ; +: with-implementors ( class generic quot -- ) + [ swap implementors-map get at ] dip call ; inline + : reveal-method ( method class generic -- ) - [ set-at ] with-methods ; + [ [ conjoin ] with-implementors ] + [ [ set-at ] with-methods ] + 2bi ; : create-method ( class generic -- method ) 2dup method dup [ @@ -142,7 +148,11 @@ M: method-body forget* [ "method-generic" word-prop ] bi 2dup method ] keep eq? - [ [ delete-at ] with-methods ] [ 2drop ] if + [ + [ [ delete-at ] with-methods ] + [ [ delete-at ] with-implementors ] + 2bi + ] [ 2drop ] if ] if ] [ call-next-method ] bi @@ -151,33 +161,6 @@ M: method-body forget* M: method-body smart-usage "method-generic" word-prop smart-usage ; -GENERIC: implementors ( class/classes -- seq ) - -M: class implementors - all-words [ "methods" word-prop key? ] with filter ; - -M: sequence implementors - all-words [ - "methods" word-prop keys - swap [ memq? ] curry contains? - ] with filter ; - -: forget-methods ( class -- ) - [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; - -: forget-class ( class -- ) - class-usages [ - { - [ forget-predicate ] - [ forget-methods ] - [ update-map- ] - [ reset-class ] - } cleave - ] each ; - -M: class forget* ( class -- ) - [ forget-class ] [ call-next-method ] bi ; - M: sequence update-methods ( class seq -- ) implementors [ [ update-generic ] [ make-generic drop ] 2bi @@ -188,6 +171,7 @@ M: sequence update-methods ( class seq -- ) 2drop ] [ 2dup "combination" set-word-prop + over "methods" word-prop values forget-all over H{ } clone "methods" set-word-prop dupd define-default-method make-generic diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index 894412d922..f7a37691a6 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -33,7 +33,7 @@ HELP: group { $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } { $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } { $examples - { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } + { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } } ; HELP: @@ -41,7 +41,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USING: arrays kernel prettyprint sequences splitting ;" + "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } } ; @@ -51,7 +51,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USING: arrays kernel prettyprint sequences splitting ;" + "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 " "dup [ reverse-here ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" @@ -68,7 +68,7 @@ HELP: clump { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } { $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." } { $examples - { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } + { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } } ; HELP: @@ -77,7 +77,7 @@ HELP: { $examples "Running averages:" { $example - "USING: splitting sequences math prettyprint kernel ;" + "USING: grouping sequences math prettyprint kernel ;" "IN: scratchpad" ": share-price" " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index 0ab016b0fa..fd4e11901a 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -95,10 +95,8 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; : namestack. ( seq -- ) - [ - [ global eq? not ] filter - [ keys ] map concat prune - ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; + [ [ global eq? not ] filter [ keys ] gather ] keep + [ dupd assoc-stack ] curry H{ } map>assoc describe ; : .vars ( -- ) namestack namestack. ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 3fe6f9d6aa..4a9f90cb32 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- ) GENERIC: ( stream encoding -- newstream ) -: replacement-char HEX: fffd ; +: replacement-char HEX: fffd ; inline TUPLE: decoder stream code cr ; @@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ; INSTANCE: encoder plain-writer PRIVATE> -: re-encode ( stream encoding -- newstream ) - over encoder? [ >r encoder-stream r> ] when ; +GENERIC# re-encode 1 ( stream encoding -- newstream ) + +M: object re-encode ; + +M: encoder re-encode [ stream>> ] dip re-encode ; : encode-output ( encoding -- ) output-stream [ swap re-encode ] change ; -: re-decode ( stream encoding -- newstream ) - over decoder? [ >r decoder-stream r> ] when ; +: with-encoded-output ( encoding quot -- ) + [ [ output-stream get ] dip re-encode ] dip + with-output-stream* ; inline + +GENERIC# re-decode 1 ( stream encoding -- newstream ) + +M: object re-decode ; + +M: decoder re-decode [ stream>> ] dip re-decode ; : decode-input ( encoding -- ) input-stream [ swap re-decode ] change ; + +: with-decoded-input ( encoding quot -- ) + [ [ input-stream get ] dip re-decode ] dip + with-input-stream* ; inline diff --git a/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor index ac5caba61c..fd251c76db 100755 --- a/core/io/encodings/utf16/utf16-tests.factor +++ b/core/io/encodings/utf16/utf16-tests.factor @@ -1,5 +1,6 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io unicode +io.streams.byte-array sequences io.encodings io +bootstrap.unicode io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index af169854c9..a99575b4ba 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,4 +1,5 @@ -USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays +bootstrap.unicode ; IN: io.encodings.utf8.tests : decode-utf8-w/stream ( array -- newarray ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 82f0db1364..a04a698965 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -401,7 +401,7 @@ HELP: clone { $values { "obj" object } { "cloned" "a new object" } } { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; -HELP: ? ( ? true false -- true/false ) +HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; @@ -409,7 +409,7 @@ HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; -HELP: not ( obj -- ? ) +HELP: not { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." } { $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ; @@ -692,26 +692,26 @@ HELP: tri@ } } ; -HELP: if ( cond true false -- ) -{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } +HELP: if +{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; HELP: when -{ $values { "cond" "a generalized boolean" } { "true" quotation } } +{ $values { "?" "a generalized boolean" } { "true" quotation } } { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: unless -{ $values { "cond" "a generalized boolean" } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: if* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." @@ -720,14 +720,14 @@ $nl { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; HELP: when* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } { $description "Variant of " { $link if* } " with no false quotation." $nl "The following two lines are equivalent:" { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ; HELP: unless* -{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } } +{ $values { "?" "a generalized boolean" } { "false" "a quotation " } } { $description "Variant of " { $link if* } " with no true quotation." } { $notes "The following two lines are equivalent:" @@ -794,7 +794,7 @@ HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; -HELP: curry ( obj quot -- curry ) +HELP: curry { $values { "obj" object } { "quot" callable } { "curry" curry } } { $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." } { $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." } @@ -832,7 +832,7 @@ HELP: with { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; -HELP: compose ( quot1 quot2 -- compose ) +HELP: compose { $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $notes diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 61f687c95a..1a7d1de47c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -28,20 +28,20 @@ DEFER: if : if ( ? true false -- ) ? call ; ! Single branch -: unless ( cond false -- ) +: unless ( ? false -- ) swap [ drop ] [ call ] if ; inline -: when ( cond true -- ) +: when ( ? true -- ) swap [ call ] [ drop ] if ; inline ! Anaphoric -: if* ( cond true false -- ) +: if* ( ? true false -- ) pick [ drop call ] [ 2nip call ] if ; inline -: when* ( cond true -- ) +: when* ( ? true -- ) over [ call ] [ 2drop ] if ; inline -: unless* ( cond false -- ) +: unless* ( ? false -- ) over [ drop ] [ nip call ] if ; inline ! Default diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index cd2a3c20c8..a1ba16c68a 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -24,7 +24,7 @@ ABOUT: "floats" HELP: float { $class-description "The class of double-precision floating point numbers." } ; -HELP: >float ( x -- y ) +HELP: >float { $values { "x" real } { "y" float } } { $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index 056e19e1de..c75040b6bb 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -23,17 +23,21 @@ ABOUT: "integers" HELP: fixnum { $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ; -HELP: >fixnum ( x -- n ) +HELP: >fixnum { $values { "x" real } { "n" fixnum } } { $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ; HELP: bignum { $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ; -HELP: >bignum ( x -- n ) +HELP: >bignum { $values { "x" real } { "n" bignum } } { $description "Converts a real number to a bignum, with a possible loss of precision." } ; +HELP: >integer +{ $values { "x" real } { "n" bignum } } +{ $description "Converts a real number to an integer, with a possible loss of precision." } ; + HELP: integer { $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 0218ded6ff..1dfbf1fc3e 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -3,9 +3,9 @@ USING: kernel math.private ; IN: math -GENERIC: >fixnum ( x -- y ) foldable -GENERIC: >bignum ( x -- y ) foldable -GENERIC: >integer ( x -- y ) foldable +GENERIC: >fixnum ( x -- n ) foldable +GENERIC: >bignum ( x -- n ) foldable +GENERIC: >integer ( x -- n ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 5fbec9a7c8..d825faf921 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -16,6 +16,9 @@ IN: sets [ ] [ length ] [ length ] tri [ [ (prune) ] 2curry each ] keep ; +: gather ( seq quot -- newseq ) + map concat prune ; inline + : unique ( seq -- assoc ) [ dup ] H{ } map>assoc ; diff --git a/core/words/words.factor b/core/words/words.factor index 806625aa83..d17377fdca 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -148,8 +148,12 @@ M: object redefined drop ; 2dup "declared-effect" word-prop = [ 2drop ] [ swap [ "declared-effect" set-word-prop ] - [ drop [ redefined ] [ +inlined+ changed-definition ] bi ] - 2bi + [ + drop + dup primitive? [ drop ] [ + [ redefined ] [ +inlined+ changed-definition ] bi + ] if + ] 2bi ] if ; : define-declared ( word def effect -- ) diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index c2e80fee9a..701a784ea4 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -7,7 +7,7 @@ kernel io.files bootstrap.image sequences io ; : url "http://factorcode.org/images/latest/" ; : download-checksums ( -- alist ) - url "checksums.txt" append http-get + url "checksums.txt" append http-get nip string-lines [ " " split1 ] { } map>assoc ; : need-new-image? ( image -- ? ) diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor new file mode 100755 index 0000000000..0476cbf18b --- /dev/null +++ b/extra/bootstrap/unicode/unicode.factor @@ -0,0 +1,12 @@ +USING: parser kernel namespaces ; + +USE: unicode.breaks +USE: unicode.case +USE: unicode.categories +USE: unicode.collation +USE: unicode.data +USE: unicode.normalize +USE: unicode.script + +[ name>char [ "Invalid character" throw ] unless* ] +name>char-hook set-global diff --git a/extra/db/db.factor b/extra/db/db.factor index 8d1feca6c7..889eff196c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; -TUPLE: statement handle sql in-params out-params bind-params bound? type ; +TUPLE: statement handle sql in-params out-params bind-params bound? type retries ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; @@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- ) swap >>out-params swap >>in-params swap >>sql ; - + : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index e99bc41449..9d2ced3afa 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 -alien.strings io.streams.byte-array inspector ; +alien.strings io.streams.byte-array inspector present urls ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str ) { TIME [ dup [ timestamp>hms ] when default-param-value ] } { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] } { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] } + { URL [ dup [ present ] when default-param-value ] } [ drop default-param-value ] } case 2array ] 2map flip dup empty? [ @@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] } { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] } { BLOB [ pq-get-blob ] } + { URL [ pq-get-string dup [ >url ] when ] } { FACTOR-BLOB [ pq-get-blob dup [ bytes>object ] when ] } diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f55897db88..e57efbc360 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable ) { TIMESTAMP { "timestamp" "timestamp" f } } { BLOB { "bytea" "bytea" f } } { FACTOR-BLOB { "bytea" "bytea" f } } + { URL { "varchar" "varchar" f } } { +foreign-id+ { f f "references" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 59ee60aa1f..807aeda74a 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random strings math.parser math.intervals combinators -math.bitfields.lib namespaces.lib db db.tuples db.types ; +math.bitfields.lib namespaces.lib db db.tuples db.types +sequences.lib db.sql classes words shuffle arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ; ] with filter ; : where-clause ( tuple specs -- ) - dupd filter-slots - dup empty? [ - 2drop + dupd filter-slots [ + drop ] [ " where " 0% [ " and " 0% ] [ 2dup slot-name>> swap get-slot-named where ] interleave drop - ] if ; + ] if-empty ; M: db ( tuple table -- sql ) [ @@ -146,15 +146,52 @@ M: db ( tuple class -- statement ) number>string " limit " prepend append ] curry change-sql drop ; -: make-advanced-statement ( tuple advanced -- tuple' ) +: make-query ( tuple query -- tuple' ) dupd { - [ group>> [ do-group ] [ drop ] if* ] - [ order>> [ do-order ] [ drop ] if* ] + [ group>> [ do-group ] [ drop ] if-seq ] + [ order>> [ do-order ] [ drop ] if-seq ] [ limit>> [ do-limit ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class group order limit offset -- tuple ) - advanced-statement boa - [ ] dip make-advanced-statement ; +M: db ( tuple class query -- tuple ) + [ ] dip make-query ; + +! select ID, NAME, SCORE from EXAM limit 1 offset 3 + +: select-tuples* ( tuple -- statement ) + dup + [ + select 0, + dup class db-columns [ ", " 0, ] + [ dup column-name>> 0, 2, ] interleave + from 0, + class word-name 0, + ] { { } { } { } } nmake + >r >r parse-sql 4drop r> r> + maybe-make-retryable do-select ; + +M: db ( tuple class groups -- statement ) + \ query new + swap >>group + [ [ "select count(*) from " 0% 0% where-clause ] query-make ] + dip make-query ; + +: where-clause* ( tuple specs -- ) + dupd filter-slots [ + drop + ] [ + \ where 0, + [ 2dup slot-name>> swap get-slot-named where ] map 2array 0, + drop + ] if-empty ; + +: delete-tuple* ( tuple -- sql ) + dup + [ + delete 0, from 0, dup class db-table 0, + dup class db-columns where-clause* + ] { { } { } { } } nmake + >r >r parse-sql 4drop r> r> + maybe-make-retryable do-select ; diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index ae748731b1..7dd4abf4be 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -23,12 +23,27 @@ DEFER: sql% : sql-function, ( seq function -- ) sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; +: sql-where ( seq -- ) +B + [ + [ second 0, ] + [ first 0, ] + [ third 1, \ ? 0, ] tri + ] each ; + : sql-array% ( array -- ) +B unclip { + { \ create [ "create table" sql% ] } + { \ drop [ "drop table" sql% ] } + { \ insert [ "insert into" sql% ] } + { \ update [ "update" sql% ] } + { \ delete [ "delete" sql% ] } + { \ select [ B "select" sql% "," (sql-interleave) ] } { \ columns [ "," (sql-interleave) ] } { \ from [ "from" "," sql-interleave ] } - { \ where [ "where" "and" sql-interleave ] } + { \ where [ B "where" 0, sql-where ] } { \ group-by [ "group by" "," sql-interleave ] } { \ having [ "having" "," sql-interleave ] } { \ order-by [ "order by" "," sql-interleave ] } @@ -49,7 +64,7 @@ DEFER: sql% ERROR: no-sql-match ; : sql% ( obj -- ) { - { [ dup string? ] [ " " 0% 0% ] } + { [ dup string? ] [ 0, ] } { [ dup array? ] [ sql-array% ] } { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } @@ -59,13 +74,4 @@ ERROR: no-sql-match ; } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) - [ - unclip { - { \ create [ "create table" sql% ] } - { \ drop [ "drop table" sql% ] } - { \ insert [ "insert into" sql% ] } - { \ update [ "update" sql% ] } - { \ delete [ "delete" sql% ] } - { \ select [ "select" sql% ] } - } case [ sql% ] each - ] { "" { } { } { } { } } nmake ; + [ [ sql% ] each ] { { } { } { } } nmake ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b652e8fed7..4c440acc55 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend db.errors ; +io.backend db.errors present urls ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ; object>bytes sqlite-bind-blob-by-name ] } + { URL [ present sqlite-bind-text-by-name ] } { +db-assigned-id+ [ sqlite-bind-int-by-name ] } { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } @@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ; { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { BLOB [ sqlite-column-blob ] } + { URL [ sqlite3_column_text dup [ >url ] when ] } { FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index cc4e4d116a..c7c9065b43 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc ) { DOUBLE { "real" "real" } } { BLOB { "blob" "blob" } } { FACTOR-BLOB { "blob" "blob" } } + { URL { "text" "text" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } { +default+ { f f "default" } } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index f9a597e814..36e84187eb 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -4,26 +4,27 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitfields.lib -math.ranges strings sequences.lib ; +math.ranges strings sequences.lib urls ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real -ts date time blob factor-blob ; +ts date time blob factor-blob url ; -: ( name age real ts date time blob factor-blob -- person ) - { - set-person-the-name - set-person-the-number - set-person-the-real - set-person-ts - set-person-date - set-person-time - set-person-blob - set-person-factor-blob - } person construct ; +: ( name age real ts date time blob factor-blob url -- person ) + person new + swap >>url + swap >>factor-blob + swap >>blob + swap >>time + swap >>date + swap >>ts + swap >>the-real + swap >>the-number + swap >>the-name ; -: ( id name age real ts date time blob factor-blob -- person ) - [ set-person-the-id ] keep ; +: ( id name age real ts date time blob factor-blob url -- person ) + + swap >>the-id ; SYMBOL: person1 SYMBOL: person2 @@ -103,6 +104,7 @@ SYMBOL: person4 T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } + URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" } ] [ T{ person f 4 } select-tuple ] unit-test @@ -120,19 +122,20 @@ SYMBOL: person4 { "time" "T" TIME } { "blob" "B" BLOB } { "factor-blob" "FB" FACTOR-BLOB } + { "url" "U" URL } } define-persistent - "billy" 10 3.14 f f f f f person1 set - "johnny" 10 3.14 f f f f f person2 set + "billy" 10 3.14 f f f f f f person1 set + "johnny" 10 3.14 f f f f f f person2 set "teddy" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f person3 set "eddie" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; : user-assigned-person-schema ( -- ) person "PERSON" @@ -146,20 +149,21 @@ SYMBOL: person4 { "time" "T" TIME } { "blob" "B" BLOB } { "factor-blob" "FB" FACTOR-BLOB } + { "url" "U" URL } } define-persistent - 1 "billy" 10 3.14 f f f f f person1 set - 2 "johnny" 10 3.14 f f f f f person2 set + 1 "billy" 10 3.14 f f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f f person2 set 3 "teddy" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } B{ 115 116 111 114 101 105 110 97 98 108 111 98 } - f person3 set + f f person3 set 4 "eddie" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -227,7 +231,7 @@ TUPLE: exam id name score ; : random-exam ( -- exam ) f - 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string + 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string 100 random exam boa ; @@ -340,7 +344,9 @@ TUPLE: exam id name score ; } ] [ T{ exam } select-tuples - ] unit-test ; + ] unit-test + + [ 4 ] [ T{ exam } f count-tuples ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0fe2f3577e..4903adff5c 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -42,8 +42,9 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) -TUPLE: advanced-statement group order offset limit ; -HOOK: db ( tuple class group order offset limit -- tuple ) +TUPLE: query group order offset limit ; +HOOK: db ( tuple class query -- statement' ) +HOOK: db ( tuple class groups -- n ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -55,6 +56,7 @@ SINGLETON: retryable [ make-retryable ] map ] [ retryable >>type + 10 >>retries ] if ; : regenerate-params ( statement -- statement ) @@ -69,12 +71,13 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop - [ - [ query-results dispose t ] - [ ] - [ regenerate-params bind-statement* f ] cleanup - ] curry 10 retry drop ; + drop [ + [ + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry + ] [ retries>> ] bi retry drop ; : resulting-tuple ( class row out-params -- tuple ) rot class new [ @@ -146,12 +149,21 @@ M: retryable execute-statement* ( statement type -- ) : do-select ( exemplar-tuple statement -- tuples ) [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; +: query ( tuple query -- tuples ) + >r dup dup class r> do-select ; + : select-tuples ( tuple -- tuples ) dup dup class do-select ; -: count-tuples ( tuple -- n ) - select-tuples length ; - : select-tuple ( tuple -- tuple/f ) - dup dup class f f f 1 - do-select ?first ; + dup dup class \ query new 1 >>limit do-select ?first ; + +: do-count ( exemplar-tuple statement -- tuples ) + [ + [ bind-tuple ] [ nip default-query ] 2bi + ] with-disposal ; + +: count-tuples ( tuple groups -- n ) + >r dup dup class r> do-count + dup length 1 = + [ first first string>number ] [ [ first string>number ] map ] if ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 03e6b15bdb..f6d54404de 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB -FACTOR-BLOB NULL ; +FACTOR-BLOB NULL URL ; : spec>tuple ( class spec -- tuple ) 3 f pad-right diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 47d352b6b8..f6fccd42ec 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -6,7 +6,7 @@ IN: html.parser.analyzer TUPLE: link attributes clickable ; : scrape-html ( url -- vector ) - http-get parse-html ; + http-get nip parse-html ; : (find-relative) [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor index 3078cf23a5..d352a97688 100644 --- a/extra/html/parser/printer/printer.factor +++ b/extra/html/parser/printer/printer.factor @@ -2,7 +2,7 @@ USING: assocs html.parser html.parser.utils combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint quotations sequences splitting -state-parser strings ; +strings ; IN: html.parser.printer SYMBOL: no-section @@ -16,7 +16,8 @@ TUPLE: state section ; TUPLE: text-printer ; TUPLE: ui-printer ; TUPLE: src-printer ; -UNION: printer text-printer ui-printer src-printer ; +TUPLE: html-prettyprinter ; +UNION: printer text-printer ui-printer src-printer html-prettyprinter ; HOOK: print-tag printer ( tag -- ) HOOK: print-text-tag printer ( tag -- ) HOOK: print-comment-tag printer ( tag -- ) @@ -47,7 +48,7 @@ M: printer print-comment-tag ( tag -- ) tag-text write "-->" write ; -M: printer print-dtd-tag +M: printer print-dtd-tag ( tag -- ) "" write ; @@ -70,8 +71,8 @@ M: printer print-closing-named-tag ( tag -- ) M: src-printer print-opening-named-tag ( tag -- ) "<" write - dup tag-name write - tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if + [ tag-name write ] + [ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi ">" write ; M: src-printer print-closing-named-tag ( tag -- ) @@ -79,9 +80,30 @@ M: src-printer print-closing-named-tag ( tag -- ) tag-name write ">" write ; -TUPLE: unknown-tag-error tag ; +SYMBOL: tab-width +SYMBOL: #indentations -C: unknown-tag-error +: html-pp ( vector -- ) + [ + 0 #indentations set + 2 tab-width set + + ] with-scope ; + +: print-tabs ( -- ) + tab-width get #indentations get * CHAR: \s write ; + +M: html-prettyprinter print-opening-named-tag ( tag -- ) + print-tabs "<" write + tag-name write + ">\n" write ; + +M: html-prettyprinter print-closing-named-tag ( tag -- ) + "" write ; + +ERROR: unknown-tag-error tag ; M: printer print-tag ( tag -- ) { @@ -92,15 +114,12 @@ M: printer print-tag ( tag -- ) [ print-closing-named-tag ] } { [ dup tag-name string? ] [ print-opening-named-tag ] } - [ throw ] + [ unknown-tag-error ] } cond ; -SYMBOL: tablestack - -: with-html-printer - [ - V{ } clone tablestack set - ] with-scope ; +! SYMBOL: tablestack +! : with-html-printer ( vector quot -- ) + ! [ V{ } clone tablestack set ] with-scope ; ! { { 1 2 } { 3 4 } } ! H{ { table-gap { 10 10 } } } [ diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 5083b1cec2..592503e3dd 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -1,7 +1,7 @@ USING: assocs circular combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint quotations sequences splitting -state-parser strings ; +state-parser strings sequences.lib ; IN: html.parser.utils : string-parse-end? @@ -13,7 +13,7 @@ IN: html.parser.utils dup length rot length 1- - head next* ; : trim1 ( seq ch -- newseq ) - [ ?head drop ] keep ?tail drop ; + [ ?head drop ] [ ?tail drop ] bi ; : single-quote ( str -- newstr ) >r "'" r> "'" 3append ; @@ -26,11 +26,7 @@ IN: html.parser.utils [ double-quote ] [ single-quote ] if ; : quoted? ( str -- ? ) - dup length 1 > [ - [ first ] keep peek [ = ] keep "'\"" member? and - ] [ - drop f - ] if ; + [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ; : ?quote ( str -- newstr ) dup quoted? [ quote ] unless ; @@ -39,4 +35,3 @@ IN: html.parser.utils dup quoted? [ but-last-slice rest-slice >string ] when ; : quote? ( ch -- ? ) "'\"" member? ; - diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7b48bf93af..56957b021c 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -3,8 +3,13 @@ USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings splitting calendar continuations accessors vectors math.order -io.encodings.8-bit io.encodings.binary io.streams.duplex -fry debugger inspector ascii urls ; +io.encodings +io.encodings.string +io.encodings.ascii +io.encodings.8-bit +io.encodings.binary +io.streams.duplex +fry debugger inspector ascii urls present ; IN: http.client : max-redirects 10 ; @@ -15,7 +20,7 @@ M: too-many-redirects summary drop [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; -DEFER: http-request +DEFER: (http-request) >method http-request + "GET" >>method (http-request) ] [ too-many-redirects ] if @@ -45,15 +50,21 @@ PRIVATE> : read-chunks ( -- ) read-chunk-size dup zero? - [ drop ] [ read % read-crlf "" assert= read-chunks ] if ; + [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ; : read-response-body ( response -- response data ) - dup "transfer-encoding" header "chunked" = - [ [ read-chunks ] "" make ] [ input-stream get contents ] if ; + dup "transfer-encoding" header "chunked" = [ + binary decode-input + [ read-chunks ] B{ } make + over content-charset>> decode + ] [ + dup content-charset>> decode-input + input-stream get contents + ] if ; -: http-request ( request -- response data ) +: (http-request) ( request -- response data ) dup request [ - dup url>> url-addr latin1 [ + dup url>> url-addr ascii [ 1 minutes timeouts write-request read-response @@ -62,14 +73,6 @@ PRIVATE> do-redirect ] with-variable ; -: ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; - -: http-get* ( url -- response data ) - http-request ; - : success? ( code -- ? ) 200 = ; ERROR: download-failed response body ; @@ -84,18 +87,28 @@ M: download-failed error. ] [ body>> write ] bi ; -: check-response ( response string -- string ) - over code>> success? [ nip ] [ download-failed ] if ; +: check-response ( response data -- response data ) + over code>> success? [ download-failed ] unless ; -: http-get ( url -- string ) - http-get* check-response ; +: http-request ( request -- response data ) + (http-request) check-response ; + +: ( url -- request ) + + "GET" >>method + swap >url ensure-port >>url ; + +: http-get ( url -- response data ) + http-request ; : download-name ( url -- name ) - file-name "?" split1 drop "/" ?tail drop ; + present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - [ http-get ] dip latin1 [ write ] with-file-writer ; + swap http-get + [ content-charset>> ] [ '[ , write ] ] bi* + with-file-writer ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index c1d5b46aa4..81ada558f3 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences +io.streams.string io.encodings.utf8 io.encodings.string +kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls hashtables ; IN: http.tests @@ -78,7 +79,7 @@ must-fail-with STRING: read-response-test-1 HTTP/1.1 404 not found -Content-Type: text/html; charset=UTF8 +Content-Type: text/html; charset=UTF-8 blah ; @@ -88,10 +89,10 @@ blah version: "1.1" code: 404 message: "not found" - header: H{ { "content-type" "text/html; charset=UTF8" } } + header: H{ { "content-type" "text/html; charset=UTF-8" } } cookies: { } content-type: "text/html" - content-charset: "UTF8" + content-charset: utf8 } ] [ read-response-test-1 lf>crlf @@ -101,7 +102,7 @@ blah STRING: read-response-test-1' HTTP/1.1 404 not found -content-type: text/html; charset=UTF8 +content-type: text/html; charset=UTF-8 ; @@ -160,14 +161,14 @@ test-db [ [ t ] [ "resource:extra/http/test/foo.html" ascii file-contents - "http://localhost:1237/nested/foo.html" http-get = + "http://localhost:1237/nested/foo.html" http-get nip ascii decode = ] unit-test -[ "http://localhost:1237/redirect-loop" http-get ] +[ "http://localhost:1237/redirect-loop" http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost:1237/quit" http-get + "http://localhost:1237/quit" http-get nip ] unit-test ! Dispatcher bugs @@ -194,12 +195,12 @@ test-db [ : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with +[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with +[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test [ ] [ [ @@ -218,9 +219,9 @@ test-db [ [ ] [ 100 sleep ] unit-test -[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test +[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test USING: html.components html.elements xml xml.utilities validators furnace furnace.flash ; @@ -253,7 +254,7 @@ SYMBOL: a : test-a string>xml "input" tag-named "value" swap at ; [ "3" ] [ - "http://localhost:1237/" http-get* + "http://localhost:1237/" http-get swap dup cookies>> "cookies" set session-id-key get-cookie value>> "session-id" set test-a ] unit-test @@ -273,4 +274,4 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 04bebce926..d7fc1b766e 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,6 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present io io.server io.sockets.secure +io.encodings.iana io.encodings.binary io.encodings.8-bit unicode.case unicode.categories qualified @@ -28,7 +29,8 @@ IN: http "header" get add-header ] [ - ": " split1 dup [ + ":" split1 dup [ + [ blank? ] left-trim swap >lower dup "last-header" set "header" get add-header ] [ @@ -36,20 +38,20 @@ IN: http ] if ] if ; -: read-lf ( -- string ) +: read-lf ( -- bytes ) "\n" read-until CHAR: \n assert= ; -: read-crlf ( -- string ) +: read-crlf ( -- bytes ) "\r" read-until [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; -: read-header-line ( -- ) +: (read-header) ( -- ) read-crlf dup - empty? [ drop ] [ header-line read-header-line ] if ; + empty? [ drop ] [ header-line (read-header) ] if ; : read-header ( -- assoc ) H{ } clone [ - "header" [ read-header-line ] with-variable + "header" [ (read-header) ] with-variable ] keep ; : header-value>string ( value -- string ) @@ -66,7 +68,8 @@ IN: http : write-header ( assoc -- ) >alist sort-keys [ - swap url-encode write ": " write + swap + check-header-string write ": " write header-value>string check-header-string write crlf ] assoc-each crlf ; @@ -299,6 +302,7 @@ body ; H{ } clone >>header "close" "connection" set-header now timestamp>http-string "date" set-header + latin1 >>content-charset V{ } clone >>cookies ; : read-response-version ( response -- response ) @@ -319,7 +323,9 @@ body ; read-header >>header dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ - parse-content-type [ >>content-type ] [ >>content-charset ] bi* + parse-content-type + [ >>content-type ] + [ name>encoding binary or >>content-charset ] bi* ] when* ; : read-response ( -- response ) @@ -341,7 +347,8 @@ body ; : unparse-content-type ( request -- content-type ) [ content-type>> "application/octet-stream" or ] - [ content-charset>> ] bi + [ content-charset>> encoding>name ] + bi [ "; charset=" swap 3append ] when* ; : write-response-header ( response -- response ) diff --git a/extra/http/server/responses/responses.factor b/extra/http/server/responses/responses.factor index 277ca392b7..4056f0c7f0 100644 --- a/extra/http/server/responses/responses.factor +++ b/extra/http/server/responses/responses.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: html.elements math.parser http accessors kernel -io io.streams.string ; +io io.streams.string io.encodings.utf8 ; IN: http.server.responses : ( body content-type -- response ) 200 >>code "Document follows" >>message + utf8 >>content-charset swap >>content-type swap >>body ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index fc50432030..792757b182 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,10 +1,21 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting -vocabs.loader http http.server.responses logging calendar -destructors html.elements html.streams io.server -io.encodings.8-bit io.timeouts io assocs debugger continuations -fry tools.vocabs math ; +vocabs.loader destructors assocs debugger continuations +tools.vocabs math +io +io.server +io.encodings +io.encodings.utf8 +io.encodings.ascii +io.encodings.binary +io.streams.limited +io.timeouts +fry logging calendar +http +http.server.responses +html.elements +html.streams ; IN: http.server SYMBOL: responder-nesting @@ -43,19 +54,29 @@ main-responder global [ <404> or ] change-at swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - dup write-response - request get method>> "HEAD" = [ drop ] [ - '[ , write-response-body ] - [ - development-mode get - [ http-error. ] [ drop "Response error" ] if - ] recover - ] if ; + [ write-response ] + [ + request get method>> "HEAD" = [ drop ] [ + '[ + , + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] + [ + utf8 [ + development-mode get + [ http-error. ] [ drop "Response error" throw ] if + ] with-encoded-output + ] recover + ] if + ] bi ; LOG: httpd-hit NOTICE : log-request ( request -- ) - [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ; + [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi + 3array httpd-hit ; : split-path ( string -- path ) "/" split harvest ; @@ -79,9 +100,15 @@ LOG: httpd-hit NOTICE development-mode get-global [ global [ refresh-all ] bind ] when ; +: setup-limits ( -- ) + 1 minutes timeouts + 64 1024 * limit-input ; + : handle-client ( -- ) [ - 1 minutes timeouts + setup-limits + ascii decode-input + ascii encode-output ?refresh-all read-request do-request @@ -90,7 +117,7 @@ LOG: httpd-hit NOTICE : httpd ( port -- ) dup integer? [ internet-server ] when - "http.server" latin1 [ handle-client ] with-server ; + "http.server" binary [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 1d86a73cfa..9d76c82e4a 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -29,7 +29,10 @@ TUPLE: file-responder root hook special allow-listings ; H{ } clone >>special ; : (serve-static) ( path mime-type -- response ) - [ [ binary &dispose ] dip ] + [ + [ binary &dispose ] dip + binary >>content-charset + ] [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi [ "content-length" set-header ] [ "last-modified" set-header ] bi* ; diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index a11a7adead..b645f25055 100755 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax byte-arrays alien ; +USING: help.markup help.syntax byte-arrays alien destructors ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" @@ -7,8 +7,8 @@ $nl "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." { $subsection buffer } { $subsection } -"Buffers must be manually deallocated:" -{ $subsection buffer-free } +"Buffers must be manually deallocated by calling " { $link dispose } "." +$nl "Buffer operations:" { $subsection buffer-reset } { $subsection buffer-length } @@ -40,11 +40,6 @@ HELP: { $values { "n" "a non-negative integer" } { "buffer" buffer } } { $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ; -HELP: buffer-free -{ $values { "buffer" buffer } } -{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." } -{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ; - HELP: buffer-reset { $values { "n" "a non-negative integer" } { "buffer" buffer } } { $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ; @@ -61,10 +56,6 @@ HELP: buffer-end { $values { "buffer" buffer } { "alien" alien } } { $description "Outputs the memory address of the current fill-pointer." } ; -HELP: (buffer-read) -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } -{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; - HELP: buffer-read { $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index f66f9ed313..74a1797efc 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,6 +1,7 @@ IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces byte-arrays strings accessors ; +sequences tools.test namespaces byte-arrays strings accessors +destructors ; : buffer-set ( string buffer -- ) over >byte-array over buffer-ptr byte-array>memory @@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ; 65536 dup buffer-read-all over buffer-capacity - rot buffer-free + rot dispose ] unit-test [ "hello world" "" ] [ @@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ; dup buffer-read-all >string 0 pick buffer-reset over buffer-read-all >string - rot buffer-free + rot dispose ] unit-test [ "hello" ] [ "hello world" string>buffer - 5 over buffer-read >string swap buffer-free + 5 over buffer-read >string swap dispose ] unit-test [ 11 ] [ "hello world" string>buffer - [ buffer-length ] keep buffer-free + [ buffer-length ] keep dispose ] unit-test [ "hello world" ] [ "hello" 1024 [ buffer-set ] keep " world" >byte-array over >buffer - dup buffer-read-all >string swap buffer-free + dup buffer-read-all >string swap dispose ] unit-test [ CHAR: e ] [ "hello" string>buffer - 1 over buffer-consume [ buffer-pop ] keep buffer-free + 1 over buffer-consume [ buffer-pop ] keep dispose ] unit-test "hello world" string>buffer "b" set [ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test -"b" get buffer-free +"b" get dispose 100 "b" set [ 1000 "b" get n>buffer >string ] must-fail -"b" get buffer-free +"b" get dispose diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index d5b917246a..a65717fb86 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -1,77 +1,101 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight. ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors alien.c-types alien.syntax kernel -kernel.private libc math sequences byte-arrays strings hints -accessors math.order ; +USING: accessors alien alien.accessors alien.c-types +alien.syntax kernel libc math sequences byte-arrays strings +hints accessors math.order destructors combinators ; IN: io.buffers -TUPLE: buffer size ptr fill pos ; +TUPLE: buffer size ptr fill pos disposed ; : ( n -- buffer ) - dup malloc 0 0 buffer boa ; + dup malloc 0 0 f buffer boa ; -: buffer-free ( buffer -- ) - dup buffer-ptr free f swap set-buffer-ptr ; +M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) - 0 swap { set-buffer-fill set-buffer-pos } set-slots ; - -: buffer-consume ( n buffer -- ) - [ buffer-pos + ] keep - [ buffer-fill min ] keep - [ set-buffer-pos ] keep - dup buffer-pos over buffer-fill >= [ - 0 over set-buffer-pos - 0 over set-buffer-fill - ] when drop ; - -: buffer@ ( buffer -- alien ) - dup buffer-pos swap buffer-ptr ; - -: buffer-end ( buffer -- alien ) - dup buffer-fill swap buffer-ptr ; - -: buffer-peek ( buffer -- byte ) - buffer@ 0 alien-unsigned-1 ; - -: buffer-pop ( buffer -- byte ) - dup buffer-peek 1 rot buffer-consume ; - -: (buffer-read) ( n buffer -- byte-array ) - [ [ fill>> ] [ pos>> ] bi - min ] keep - buffer@ swap memory>byte-array ; - -: buffer-read ( n buffer -- byte-array ) - [ (buffer-read) ] [ buffer-consume ] 2bi ; - -: buffer-length ( buffer -- n ) - [ fill>> ] [ pos>> ] bi - ; + swap >>fill 0 >>pos drop ; : buffer-capacity ( buffer -- n ) - [ size>> ] [ fill>> ] bi - ; + [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; +: buffer-consume ( n buffer -- ) + [ + ] change-pos + dup [ pos>> ] [ fill>> ] bi < + [ 0 >>pos 0 >>fill ] unless drop ; inline + +: buffer-peek ( buffer -- byte ) + [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline + +: buffer-pop ( buffer -- byte ) + [ buffer-peek ] [ 1 swap buffer-consume ] bi ; + +HINTS: buffer-pop buffer ; + +: buffer-length ( buffer -- n ) + [ fill>> ] [ pos>> ] bi - ; inline + +: buffer@ ( buffer -- alien ) + [ pos>> ] [ ptr>> ] bi ; + +: buffer-read ( n buffer -- byte-array ) + [ buffer-length min ] keep + [ buffer@ ] [ buffer-consume ] 2bi + swap memory>byte-array ; + +HINTS: buffer-read fixnum buffer ; + : extend-buffer ( n buffer -- ) - 2dup buffer-ptr swap realloc - over set-buffer-ptr set-buffer-size ; + 2dup ptr>> swap realloc >>ptr swap >>size drop ; + inline : check-overflow ( n buffer -- ) 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; + inline -: >buffer ( byte-array buffer -- ) - over length over check-overflow - [ buffer-end byte-array>memory ] 2keep - [ buffer-fill swap length + ] keep set-buffer-fill ; - -: byte>buffer ( byte buffer -- ) - 1 over check-overflow - [ buffer-end 0 set-alien-unsigned-1 ] keep - [ 1+ ] change-fill drop ; +: buffer-end ( buffer -- alien ) + [ fill>> ] [ ptr>> ] bi ; inline : n>buffer ( n buffer -- ) - [ buffer-fill + ] keep - [ buffer-size > [ "Buffer overflow" throw ] when ] 2keep - set-buffer-fill ; + [ + ] change-fill + [ fill>> ] [ size>> ] bi > + [ "Buffer overflow" throw ] when ; inline + +: >buffer ( byte-array buffer -- ) + [ [ length ] dip check-overflow ] + [ buffer-end byte-array>memory ] + [ [ length ] dip n>buffer ] + 2tri ; + +HINTS: >buffer byte-array buffer ; + +: byte>buffer ( byte buffer -- ) + [ 1 swap check-overflow ] + [ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ] + [ 1 swap n>buffer ] + tri ; + +HINTS: byte>buffer fixnum buffer ; + +: search-buffer-until ( pos fill ptr separators -- n ) + [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; + +: finish-buffer-until ( buffer n -- byte-array separator ) + [ + over pos>> - + over buffer-read + swap buffer-pop + ] [ + [ buffer-length ] keep + buffer-read f + ] if* ; + +: buffer-until ( separators buffer -- byte-array separator ) + swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip + search-buffer-until + finish-buffer-until ; + +HINTS: buffer-until { string buffer } ; diff --git a/extra/io/encodings/8-bit/8-bit-tests.factor b/extra/io/encodings/8-bit/8-bit-tests.factor index 24cd4137d4..8b18e2a9af 100644 --- a/extra/io/encodings/8-bit/8-bit-tests.factor +++ b/extra/io/encodings/8-bit/8-bit-tests.factor @@ -1,4 +1,5 @@ -USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ; +USING: io.encodings.string io.encodings.8-bit +io.encodings.8-bit.private tools.test strings arrays ; IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test @@ -8,3 +9,6 @@ IN: io.encodings.8-bit.tests [ "bar" ] [ "bar" latin1 decode ] unit-test [ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test [ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test + +[ t ] [ \ latin1 8-bit-encoding? ] unit-test +[ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index d4e6122321..71c57ef68c 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -73,6 +73,13 @@ M: 8-bit decode-char : define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; +PREDICATE: 8-bit-encoding < word + word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ; + +M: 8-bit-encoding word-def first ; + +M: 8-bit-encoding word-def first ; + PRIVATE> [ diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor index dd429c1670..4368360a4d 100755 --- a/extra/io/encodings/iana/iana.factor +++ b/extra/io/encodings/iana/iana.factor @@ -41,6 +41,13 @@ PRIVATE> [ second ] map { "None" } diff ] map ; +: more-aliases ( -- assoc ) + H{ + { "UTF8" utf8 } + { "utf8" utf8 } + { "utf-8" utf8 } + } ; + : make-n>e ( stream -- n>e ) parse-iana [ [ dup [ @@ -48,7 +55,7 @@ PRIVATE> [ swap [ set ] with each ] [ drop ] if* ] with each - ] each ] H{ } make-assoc ; + ] each ] H{ } make-assoc more-aliases assoc-union ; PRIVATE> "resource:extra/io/encodings/iana/character-sets" diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 1cbbac7f20..b761ecaf5b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -71,6 +71,28 @@ M: input-port stream-read ] [ 2nip ] if ] [ 2nip ] if ; +: read-until-step ( separators port -- string/f separator/f ) + dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ; + +: read-until-loop ( seps port buf -- separator/f ) + 2over read-until-step over [ + >r over push-all r> dup [ + >r 3drop r> + ] [ + drop read-until-loop + ] if + ] [ + >r 2drop 2drop r> + ] if ; + +M: input-port stream-read-until ( seps port -- str/f sep/f ) + 2dup read-until-step dup [ >r 2nip r> ] [ + over [ + drop + BV{ } like [ read-until-loop ] keep B{ } like swap + ] [ >r 2nip r> ] if + ] if ; + TUPLE: output-port < buffered-port ; : ( handle -- output-port ) @@ -121,7 +143,7 @@ M: output-port dispose* M: buffered-port dispose* [ call-next-method ] - [ [ [ buffer-free ] when* f ] change-buffer drop ] + [ [ [ dispose ] when* f ] change-buffer drop ] bi ; M: port cancel-operation handle>> cancel-operation ; diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor new file mode 100644 index 0000000000..d160a3f756 --- /dev/null +++ b/extra/io/streams/limited/limited-tests.factor @@ -0,0 +1,32 @@ +IN: io.streams.limited.tests +USING: io io.streams.limited io.encodings io.encodings.string +io.encodings.ascii io.encodings.binary io.streams.byte-array +namespaces tools.test strings kernel ; + +[ ] [ + "hello world\nhow are you today\nthis is a very long line indeed" + ascii encode binary "data" set +] unit-test + +[ ] [ "data" get 24 "limited" set ] unit-test + +[ CHAR: h ] [ "limited" get stream-read1 ] unit-test + +[ ] [ "limited" get ascii "decoded" set ] unit-test + +[ "ello world" ] [ "decoded" get stream-readln ] unit-test + +[ "how " ] [ 4 "decoded" get stream-read ] unit-test + +[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with + +[ ] [ + "abc\ndef\nghi" + ascii encode binary "data" set +] unit-test + +[ ] [ "data" get 7 "limited" set ] unit-test + +[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test + +[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor new file mode 100644 index 0000000000..669240d28b --- /dev/null +++ b/extra/io/streams/limited/limited.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math io destructors accessors sequences +namespaces ; +IN: io.streams.limited + +TUPLE: limited-stream stream count limit ; + +: ( stream limit -- stream' ) + limited-stream new + swap >>limit + swap >>stream + 0 >>count ; + +: limit-input ( limit -- ) + input-stream [ swap ] change ; + +ERROR: limit-exceeded ; + +: check-limit ( n stream -- ) + [ + ] change-count + [ count>> ] [ limit>> ] bi >= + [ limit-exceeded ] when ; inline + +M: limited-stream stream-read1 + 1 over check-limit stream>> stream-read1 ; + +M: limited-stream stream-read + 2dup check-limit stream>> stream-read ; + +M: limited-stream stream-read-partial + 2dup check-limit stream>> stream-read-partial ; + +: (read-until) ( stream seps buf -- stream seps buf sep/f ) + 3dup [ [ stream-read1 dup ] dip memq? ] dip + swap [ drop ] [ push (read-until) ] if ; + +M: limited-stream stream-read-until + swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ; + +M: limited-stream dispose + stream>> dispose ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 5fed709253..9e91119247 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays assocs combinators.lib ; +splitting words byte-arrays assocs ; IN: opengl : coordinates ( point1 point2 -- x1 y2 x2 y2 ) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 784e6c064c..443b9fc61d 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib math.parser + vectors arrays math.parser unicode.categories sequences.deep peg peg.private peg.search math.ranges words memoize ; IN: peg.parsers diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor index 12beaf4cd7..32b3c925f3 100644 --- a/extra/syndication/syndication.factor +++ b/extra/syndication/syndication.factor @@ -107,7 +107,7 @@ TUPLE: entry title url description date ; : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get read-feed ; + http-get nip read-feed ; ! Atom generation : simple-tag, ( content name -- ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index e8675f5891..db0f478709 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -150,6 +150,7 @@ IN: tools.deploy.shaker classes:class-or-cache classes:class<=-cache classes:classes-intersect-cache + classes:implementors-map classes:update-map command-line:main-vocab-hook compiled-crossref diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 86035ae1a4..0319434570 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -3,7 +3,7 @@ USING: kernel combinators vocabs vocabs.loader tools.vocabs io io.files io.styles help.markup help.stylesheet sequences assocs help.topics namespaces prettyprint words sorting definitions -arrays inspector ; +arrays inspector sets ; IN: tools.vocabs.browser : vocab-status-string ( vocab -- string ) @@ -105,7 +105,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map - [ [ word? ] filter [ word-vocabulary ] map ] map>set + [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index effa17c179..63fcff7f6a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq ) [ vocab-dir? ] with filter ] curry map concat ; -: map>set ( seq quot -- ) - map concat prune natural-sort ; inline - MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] map>set ; + all-vocabs-seq [ vocab-tags ] gather natural-sort ; MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] map>set ; + all-vocabs-seq [ vocab-authors ] gather natural-sort ; : reset-cache ( -- ) root-cache get-global clear-assoc diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 70962b1ba0..2cacc4bca2 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -258,7 +258,7 @@ M: x11-ui-backend ui ( -- ) ] ui-running ; M: x11-ui-backend beep ( -- ) - dpy 100 XBell drop ; + dpy get 100 XBell drop ; x11-ui-backend ui-backend set-global diff --git a/extra/unicode/unicode.factor b/extra/unicode/unicode.factor deleted file mode 100755 index 0c22bfab8f..0000000000 --- a/extra/unicode/unicode.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: unicode.syntax unicode.data unicode.breaks -unicode.normalize unicode.case unicode.categories -parser kernel namespaces ; -IN: unicode - -! For now: convenience to load all Unicode vocabs - -[ name>char [ "Invalid character" throw ] unless* ] -name>char-hook set-global diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index c47b8be15c..d163c8f1ac 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -59,4 +59,4 @@ format similar-ok language country site subscription license ; swap >>query ; : search-yahoo ( search -- seq ) - query http-get string>xml parse-yahoo ; + query http-get nip string>xml parse-yahoo ; diff --git a/vm/Config.macosx b/vm/Config.macosx index 40eeb91322..54078cfe8d 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o DLL_EXTENSION = .dylib ifdef X11 - LIBS = -lm -framework Foundation $(X11_UI_LIBS) + LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib else LIBS = -lm -framework Cocoa -framework AppKit endif diff --git a/vm/types.c b/vm/types.c index adfdea41a5..adf8b1d4a6 100755 --- a/vm/types.c +++ b/vm/types.c @@ -283,19 +283,6 @@ DEFINE_PRIMITIVE(resize_byte_array) dpush(tag_object(reallot_byte_array(array,capacity))); } -F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count) -{ - if(*result_count == byte_array_capacity(result)) - { - result = reallot_byte_array(result,*result_count * 2); - } - - bput(BREF(result,*result_count),elt); - *result_count++; - - return result; -} - F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count) { CELL new_size = *result_count + len; diff --git a/vm/types.h b/vm/types.h index bbf7fb203d..34301964a1 100755 --- a/vm/types.h +++ b/vm/types.h @@ -212,11 +212,6 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun CELL result##_count = 0; \ CELL result = tag_object(allot_byte_array(100)) -F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count); - -#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \ - result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count)) - F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count); #define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \