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

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

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 [ <tuple-boa> ] curry ] tri define
+[ tuple-layout [ <tuple-boa> ] 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 [ <tuple-boa> ] curry ] tri define
+[ tuple-layout [ <tuple-boa> ] curry ] tri
+(( quot1 quot2 -- compose )) define-declared
 
 ! Primitive words
 : make-primitive ( word vocab n -- )

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

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" } }

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

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

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

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: <groups>
@@ -41,7 +41,7 @@ HELP: <groups>
 { $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 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
     }
 } ;
@@ -51,7 +51,7 @@ HELP: <sliced-groups>
 { $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 <sliced-groups>"
         "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: <clumps>
@@ -77,7 +77,7 @@ HELP: <clumps>
 { $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 } ;"

core/inspector/inspector.factor

@@ -95,10 +95,8 @@ SYMBOL: +editable+
 : describe ( obj -- ) H{ } describe* ;
 
 : namestack. ( seq -- )
-    [
+    [ [ global eq? not ] filter [ keys ] gather ] keep
-        [ global eq? not ] filter
+    [ dupd assoc-stack ] curry H{ } map>assoc describe ;
-        [ keys ] map concat prune
-    ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
 
 : .vars ( -- )
     namestack namestack. ;

core/io/encodings/encodings.factor

@@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- )
 
 GENERIC: <decoder> ( 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 )
+GENERIC# re-encode 1 ( stream encoding -- newstream )
-    over encoder? [ >r encoder-stream r> ] when <encoder> ;
+
+M: object re-encode <encoder> ;
+
+M: encoder re-encode [ stream>> ] dip re-encode ;
 
 : encode-output ( encoding -- )
     output-stream [ swap re-encode ] change ;
 
-: re-decode ( stream encoding -- newstream )
+: with-encoded-output ( encoding quot -- )
-    over decoder? [ >r decoder-stream r> ] when <decoder> ;
+    [ [ output-stream get ] dip re-encode ] dip
+    with-output-stream* ; inline
+
+GENERIC# re-decode 1 ( stream encoding -- newstream )
+
+M: object re-decode <decoder> ;
+
+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

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
 

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 )

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 -- )
+HELP: if
-{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
+{ $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

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

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." } ;
 

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." } ;
 

core/math/math.factor

@@ -3,9 +3,9 @@
 USING: kernel math.private ;
 IN: math
 
-GENERIC: >fixnum ( x -- y ) foldable
+GENERIC: >fixnum ( x -- n ) foldable
-GENERIC: >bignum ( x -- y ) foldable
+GENERIC: >bignum ( x -- n ) foldable
-GENERIC: >integer ( x -- y ) foldable
+GENERIC: >integer ( x -- n ) foldable
 GENERIC: >float ( x -- y ) foldable
 
 MATH: number= ( x y -- ? ) foldable

core/sets/sets.factor

@@ -16,6 +16,9 @@ IN: sets
     [ ] [ length <hashtable> ] [ length <vector> ] tri
     [ [ (prune) ] 2curry each ] keep ;
 
+: gather ( seq quot -- newseq )
+    map concat prune ; inline
+
 : unique ( seq -- assoc )
     [ dup ] H{ } map>assoc ;
 

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

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

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

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 ;
 

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 ] }

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" } }

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
+    dupd filter-slots [
-    dup empty? [
+        drop
-        2drop
     ] [
         " where " 0% [
             " and " 0%
         ] [
             2dup slot-name>> swap get-slot-named where
         ] interleave drop
-    ] if ;
+    ] if-empty ;
 
 M: db <delete-tuples-statement> ( tuple table -- sql )
     [
@@ -146,15 +146,52 @@ M: db <select-by-slots-statement> ( 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* ]
+        [ group>> [ do-group ] [ drop ] if-seq ]
-        [ order>> [ do-order ] [ drop ] if* ]
+        [ order>> [ do-order ] [ drop ] if-seq ]
         [ limit>> [ do-limit ] [ drop ] if* ]
         [ offset>> [ do-offset ] [ drop ] if* ]
     } 2cleave ;
 
-M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
+M: db <query> ( tuple class query -- tuple )
-    advanced-statement boa
+    [ <select-by-slots-statement> ] dip make-query ;
-    [ <select-by-slots-statement> ] dip make-advanced-statement ;
+
+! 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>
+    <simple-statement> maybe-make-retryable do-select ;
+
+M: db <count-statement> ( 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>
+    <simple-statement> maybe-make-retryable do-select ;

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 )
-    [
+    [ [ sql% ] each ] { { } { } { } } nmake ;
-        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 ;

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

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" } }

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 ;
 
-: <person> ( name age real ts date time blob factor-blob -- person )
+: <person> ( name age real ts date time blob factor-blob url -- person )
-    {
+    person new
-        set-person-the-name
+        swap >>url
-        set-person-the-number
+        swap >>factor-blob
-        set-person-the-real
+        swap >>blob
-        set-person-ts
+        swap >>time
-        set-person-date
+        swap >>date
-        set-person-time
+        swap >>ts
-        set-person-blob
+        swap >>the-real
-        set-person-factor-blob
+        swap >>the-number
-    } person construct ;
+        swap >>the-name ;
 
-: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
+: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
-    <person> [ set-person-the-id ] keep ;
+    <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 <person> person1 set
+    "billy" 10 3.14 f f f f f f <person> person1 set
-    "johnny" 10 3.14 f f f f f <person> person2 set
+    "johnny" 10 3.14 f f f f f f <person> 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 <person> person3 set
+        B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> 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" } } <person> 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"  <person> 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 <user-assigned-person> person1 set
+    1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
-    2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
+    2 "johnny" 10 3.14 f f f f f f <user-assigned-person> 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 <user-assigned-person> person3 set
+        f f <user-assigned-person> 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" } } <user-assigned-person> 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" <user-assigned-person> 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 ;
 : <bignum-test> ( m n o -- obj )

extra/db/tuples/tuples.factor

@@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <delete-tuples-statement> db ( tuple class -- obj )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: advanced-statement group order offset limit ;
+TUPLE: query group order offset limit ;
-HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
+HOOK: <query> db ( tuple class query -- statement' )
+HOOK: <count-statement> 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
+    drop [
         [
             [ query-results dispose t ]
             [ ]
             [ regenerate-params bind-statement* f ] cleanup
-    ] curry 10 retry drop ;
+        ] 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> <query> do-select ;
+
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> do-select ;
 
-: count-tuples ( tuple -- n )
-    select-tuples length ;
-
 : select-tuple ( tuple -- tuple/f )
-    dup dup class f f f 1 <advanced-select-statement>
+    dup dup class \ query new 1 >>limit <query> do-select ?first ;
-    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> <count-statement> do-count
+    dup length 1 =
+    [ first first string>number ] [ [ first string>number ] map ] if ;

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

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

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
     tag-text write
     ">" 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-name write ]
-    tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if
+    [ 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> unknown-tag-error
+: html-pp ( vector -- )
+    [
+        0 #indentations set
+        2 tab-width set
+        
+    ] with-scope ;
+
+: print-tabs ( -- )
+    tab-width get #indentations get * CHAR: \s <repetition> 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
+    tag-name write
+    ">" 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 ] }
-        [ <unknown-tag-error> throw ]
+        [ unknown-tag-error ]
     } cond ;
 
-SYMBOL: tablestack
+! SYMBOL: tablestack
-
+! : with-html-printer ( vector quot -- )
-: with-html-printer
+    ! [ V{ } clone tablestack set ] with-scope ;
-    [
-        V{ } clone tablestack set
-    ] with-scope ;
 
 ! { { 1 2 } { 3 4 } }
 ! H{ { table-gap { 10 10 } } } [

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 ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
-        [ first ] keep peek [ = ] keep "'\"" member? and
-    ] [
-        drop f
-    ] if ;
 
 : ?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? ;
-

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
+io.encodings
-fry debugger inspector ascii urls ;
+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)
 
 <PRIVATE
 
@@ -31,7 +36,7 @@ SYMBOL: redirects
         redirects get max-redirects < [
             request get
             swap "location" header redirect-url
-            "GET" >>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" =
+    dup "transfer-encoding" header "chunked" = [
-    [ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
+        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 ;
 
-: <get-request> ( url -- request )
-    <request>
-        "GET" >>method
-        swap >url ensure-port >>url ;
-
-: http-get* ( url -- response data )
-    <get-request> 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 )
+: check-response ( response data -- response data )
-    over code>> success? [ nip ] [ download-failed ] if ;
+    over code>> success? [ download-failed ] unless ;
 
-: http-get ( url -- string )
+: http-request ( request -- response data )
-    http-get* check-response ;
+    (http-request) check-response ;
+
+: <get-request> ( url -- request )
+    <request>
+        "GET" >>method
+        swap >url ensure-port >>url ;
+
+: http-get ( url -- response data )
+    <get-request> 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 ;

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

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
 
@@ -29,6 +30,7 @@ IN: http
         add-header
     ] [
         ":" 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 )

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
 
 : <content> ( body content-type -- response )
     <response>
         200 >>code
         "Document follows" >>message
+        utf8 >>content-charset
         swap >>content-type
         swap >>body ;
     

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
+vocabs.loader destructors assocs debugger continuations
-destructors html.elements html.streams io.server
+tools.vocabs math
-io.encodings.8-bit io.timeouts io assocs debugger continuations
+io
-fry tools.vocabs math ;
+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> <trivial-responder> or ] change-at
     swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
-    dup write-response
+    [ write-response ]
-    request get method>> "HEAD" = [ drop ] [
-        '[ , write-response-body ]
     [
+        request get method>> "HEAD" = [ drop ] [
+            '[
+                ,
+                [ content-charset>> encode-output ]
+                [ write-response-body ]
+                bi
+            ]
+            [
+                utf8 [
                     development-mode get
-            [ http-error. ] [ drop "Response error" ] if
+                    [ http-error. ] [ drop "Response error" throw ] if
+                ] with-encoded-output
             ] recover
-    ] if ;
+        ] 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 ;

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 <file-reader> &dispose ] dip <content> ]
+    [
+        [ binary <file-reader> &dispose ] dip
+        <content> binary >>content-charset
+    ]
     [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
     [ "content-length" set-header ]
     [ "last-modified" set-header ] bi* ;

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 <buffer> }
-"Buffers must be manually deallocated:"
+"Buffers must be manually deallocated by calling " { $link dispose } "."
-{ $subsection buffer-free }
+$nl
 "Buffer operations:"
 { $subsection buffer-reset }
 { $subsection buffer-length }
@@ -40,11 +40,6 @@ HELP: <buffer>
 { $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." } ;

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 <buffer>
     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> [ 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 <buffer> "b" set
 [ 1000 "b" get n>buffer >string ] must-fail
-"b" get buffer-free
+"b" get dispose

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
+USING: accessors alien alien.accessors alien.c-types
-kernel.private libc math sequences byte-arrays strings hints
+alien.syntax kernel libc math sequences byte-arrays strings
-accessors math.order ;
+hints accessors math.order destructors combinators ;
 IN: io.buffers
 
-TUPLE: buffer size ptr fill pos ;
+TUPLE: buffer size ptr fill pos disposed ;
 
 : <buffer> ( n -- buffer )
-    dup malloc 0 0 buffer boa ;
+    dup malloc 0 0 f buffer boa ;
 
-: buffer-free ( buffer -- )
+M: buffer dispose* ptr>> free ;
-    dup buffer-ptr free  f swap set-buffer-ptr ;
 
 : buffer-reset ( n buffer -- )
-    0 swap { set-buffer-fill set-buffer-pos } set-slots ;
+    swap >>fill 0 >>pos drop ;
-
-: 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 <displaced-alien> ;
-
-: buffer-end ( buffer -- alien )
-    dup buffer-fill swap buffer-ptr <displaced-alien> ;
-
-: 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 - ;
 
 : 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 <displaced-alien> ;
+
+: 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
+    2dup ptr>> swap realloc >>ptr swap >>size drop ;
-    over set-buffer-ptr set-buffer-size ;
+    inline
 
 : check-overflow ( n buffer -- )
     2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
+    inline
 
-: >buffer ( byte-array buffer -- )
+: buffer-end ( buffer -- alien )
-    over length over check-overflow
+    [ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
-    [ 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 ;
 
 : n>buffer ( n buffer -- )
-    [ buffer-fill + ] keep 
+    [ + ] change-fill
-    [ buffer-size > [ "Buffer overflow" throw ] when ] 2keep
+    [ fill>> ] [ size>> ] bi >
-    set-buffer-fill ;
+    [ "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 } ;

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

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 <encoder> word-def first <encoder> ;
+
+M: 8-bit-encoding <decoder> word-def first <decoder> ;
+
 PRIVATE>
 
 [

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"

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 ;
 
 : <output-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 ;

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 <byte-reader> "data" set
+] unit-test
+
+[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
+
+[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
+
+[ ] [ "limited" get ascii <decoder> "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 <byte-reader> "data" set
+] unit-test
+
+[ ] [ "data" get 7 <limited-stream> "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

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 ;
+
+: <limited-stream> ( stream limit -- stream' )
+    limited-stream new
+        swap >>limit
+        swap >>stream
+        0 >>count ;
+
+: limit-input ( limit -- )
+    input-stream [ swap <limited-stream> ] 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 ;

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 )

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

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

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

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

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

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
 

extra/unicode/unicode.factor

@@ -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

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 ;

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

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;

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