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

core/assocs/assocs-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences
-sequences.private namespaces classes math ;
+sequences.private namespaces math ;
 IN: assocs
 
 ARTICLE: "alists" "Association lists"
@@ -68,7 +68,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
 
 ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
-{ $subsection subassoc? }
+{ $subsection assoc-subset? }
 { $subsection assoc-intersect }
 { $subsection update }
 { $subsection assoc-union }
@@ -215,7 +215,7 @@ HELP: assoc-all?
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
 { $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
 
-HELP: subassoc?
+HELP: assoc-subset?
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
 { $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
 

core/assocs/assocs-tests.factor

@@ -3,13 +3,13 @@ USING: kernel math namespaces tools.test vectors sequences
 sequences.private hashtables io prettyprint assocs
 continuations ;
 
-[ t ] [ H{ } dup subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
 
 ! Test some combinators
 [

core/assocs/assocs.factor

@@ -98,11 +98,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-stack ( key seq -- value )
     dup length 1- swap (assoc-stack) ;
 
-: subassoc? ( assoc1 assoc2 -- ? )
+: assoc-subset? ( assoc1 assoc2 -- ? )
     [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
 
 : assoc= ( assoc1 assoc2 -- ? )
-    2dup subassoc? >r swap subassoc? r> and ;
+    [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
 
 : assoc-hashcode ( n assoc -- code )
     [

core/bootstrap/image/image.factor

@@ -305,12 +305,12 @@ M: wrapper '
     [ emit ] emit-object ;
 
 ! Strings
-: emit-chars ( seq -- )
+: emit-bytes ( seq -- )
     bootstrap-cell <groups>
     big-endian get [ [ be> ] map ] [ [ le> ] map ] if
     emit-seq ;
 
-: pack-string ( string -- newstr )
+: pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
 : emit-string ( string -- ptr )
@@ -318,7 +318,7 @@ M: wrapper '
         dup length emit-fixnum
         f ' emit
         f ' emit
-        pack-string emit-chars
+        pad-bytes emit-bytes
     ] emit-object ;
 
 M: string '
@@ -335,7 +335,11 @@ M: string '
         [ 0 emit-fixnum ] emit-object
     ] bi* ;
 
-M: byte-array ' byte-array emit-dummy-array ;
+M: byte-array '
+    byte-array type-number object tag-number [
+        dup length emit-fixnum
+        pad-bytes emit-bytes
+    ] emit-object ;
 
 M: bit-array ' bit-array emit-dummy-array ;
 
@@ -400,8 +404,8 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<-cache class-not-cache
+            update-map class<=-cache class<=>-cache
-            classes-intersect-cache class-and-cache
+            class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc

core/bootstrap/primitives.factor

@@ -59,6 +59,7 @@ num-types get f <array> builtins set
     "arrays"
     "bit-arrays"
     "byte-arrays"
+    "byte-vectors"
     "classes.private"
     "classes.tuple"
     "classes.tuple.private"
@@ -452,6 +453,22 @@ tuple
     }
 } define-tuple-class
 
+"byte-vector" "byte-vectors" create
+tuple
+{
+    {
+        { "byte-array" "byte-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
 "curry" "kernel" create
 tuple
 {

core/bootstrap/stage2.factor

@@ -44,10 +44,6 @@ SYMBOL: bootstrap-time
     "Now, you can run Factor:" print
     vm write " -i=" write "output-image" get print flush ;
 
-! Wrap everything in a catch which starts a listener so
-! you can see what went wrong, instead of dealing with a
-! fep
-
 ! We time bootstrap
 millis >r
 

core/bootstrap/syntax.factor

@@ -16,6 +16,7 @@ IN: bootstrap.syntax
     "?{"
     "BIN:"
     "B{"
+    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"

core/byte-vectors/byte-vectors.factor

@@ -1,20 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays prettyprint.backend
+sequences.private growable byte-arrays ;
-parser accessors ;
 IN: byte-vectors
 
-TUPLE: byte-vector underlying fill ;
-
-M: byte-vector underlying underlying>> { byte-array } declare ;
-
-M: byte-vector set-underlying (>>underlying) ;
-
-M: byte-vector length fill>> { array-capacity } declare ;
-
-M: byte-vector set-fill (>>fill) ;
-
 <PRIVATE
 
 : byte-array>vector ( byte-array length -- byte-vector )
@@ -43,9 +32,3 @@ M: byte-vector equal?
 M: byte-array new-resizable drop <byte-vector> ;
 
 INSTANCE: byte-vector growable
-
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
-
-M: byte-vector >pprint-sequence ;
-
-M: byte-vector pprint-delims drop \ BV{ \ } ;

core/checksums/checksums-docs.factor

@@ -0,0 +1,51 @@
+USING: help.markup help.syntax kernel math sequences quotations
+math.private byte-arrays strings ;
+IN: checksums
+
+HELP: checksum
+{ $class-description "The class of checksum algorithms." } ;
+
+HELP: hex-string
+{ $values { "seq" "a sequence" } { "str" "a string" } }
+{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
+{ $examples
+    { $example "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
+}
+{ $notes "Numbers are zero-padded on the left." } ;
+
+HELP: checksum-stream
+{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data read from the stream." }
+{ $side-effects "stream" } ;
+
+HELP: checksum-bytes
+{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-lines
+{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-file
+{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a file." } ;
+
+ARTICLE: "checksums" "Checksums"
+"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
+$nl
+"Checksums are instances of a class:"
+{ $subsection checksum }
+"Operations on checksums:"
+{ $subsection checksum-bytes }
+{ $subsection checksum-stream }
+{ $subsection checksum-lines }
+"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
+$nl
+"Utilities:"
+{ $subsection checksum-file }
+{ $subsection hex-string }
+"Checksum implementations:"
+{ $subsection "checksums.crc32" }
+{ $vocab-subsection "MD5 checksum" "checksums.md5" }
+{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;

core/checksums/checksums.factor

@@ -0,0 +1,25 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math.parser io io.streams.byte-array
+io.encodings.binary io.files kernel ;
+IN: checksums
+
+MIXIN: checksum
+
+GENERIC: checksum-bytes ( bytes checksum -- value )
+
+GENERIC: checksum-stream ( stream checksum -- value )
+
+GENERIC: checksum-lines ( lines checksum -- value )
+
+M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+
+M: checksum checksum-stream >r contents r> checksum-bytes ;
+
+M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+
+: checksum-file ( path checksum -- value )
+    >r binary <file-reader> r> checksum-stream ;
+
+: hex-string ( seq -- str )
+    [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

core/checksums/crc32/crc32-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax math ;
+IN: checksums.crc32
+
+HELP: crc32
+{ $class-description "The CRC32 checksum algorithm." } ;
+
+ARTICLE: "checksums.crc32" "CRC32 checksum"
+"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
+{ $subsection crc32 } ;
+
+ABOUT: "checksums.crc32"

core/checksums/crc32/crc32-tests.factor

@@ -0,0 +1,6 @@
+USING: checksums checksums.crc32 kernel math tools.test namespaces ;
+
+[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
+
+[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test
+

core/checksums/crc32/crc32.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences sequences.private namespaces
 words io io.binary io.files io.streams.string quotations
-definitions ;
+definitions checksums ;
-IN: io.crc32
+IN: checksums.crc32
 
 : crc32-polynomial HEX: edb88320 ; inline
 
@@ -20,10 +20,20 @@ IN: io.crc32
     mask-byte crc32-table nth-unsafe >bignum
     swap -8 shift bitxor ; inline
 
-: crc32 ( seq -- n )
+SINGLETON: crc32
-    >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: lines-crc32 ( seq -- n )
+INSTANCE: crc32 checksum
-    HEX: ffffffff tuck [
+
-        [ (crc32) ] each CHAR: \n (crc32)
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
-    ] reduce bitxor ;
+
+: finish-crc32 bitxor 4 >be ; inline
+
+M: crc32 checksum-bytes
+    init-crc32
+    [ (crc32) ] each
+    finish-crc32 ;
+
+M: crc32 checksum-lines
+    init-crc32
+    [ [ (crc32) ] each CHAR: \n (crc32) ] each
+    finish-crc32 ;

core/classes/algebra/algebra-docs.factor

@@ -1,14 +1,14 @@
-USING: help.markup help.syntax kernel classes ;
+USING: help.markup help.syntax kernel classes words
+checksums checksums.crc32 sequences math ;
 IN: classes.algebra
 
 ARTICLE: "class-operations" "Class operations"
 "Set-theoretic operations on classes:"
 { $subsection class< }
+{ $subsection class<= }
 { $subsection class-and }
 { $subsection class-or }
 { $subsection classes-intersect? }
-"Topological sort:"
-{ $subsection sort-classes }
 { $subsection min-class }
 "Low-level implementation detail:"
 { $subsection class-types }
@@ -17,6 +17,40 @@ ARTICLE: "class-operations" "Class operations"
 { $subsection class-types }
 { $subsection class-tags } ;
 
+ARTICLE: "class-linearization" "Class linearization"
+"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"
+{ $list
+    "If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."
+    { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }
+}
+"These difficulties are resolved by imposing a linear order on classes, computed as follows for two classes A and B:"
+{ $list
+    "If A and B are the same class (not just equal as sets), then comparison stops."
+    "If A is a proper subset of B, or B is a proper subset of A, then comparison stops."
+    { "Next, the metaclasses of A and B are compared, with intrinsic meta-class order, from most-specific to least-specific:"
+        { $list
+            "Built-in classes and tuple classes"
+            "Predicate classes"
+            "Union classes"
+            "Mixin classes"
+        }
+    "If this yields an unambiguous answer, comparison stops."
+    }
+    "If the metaclasses of A and B occupy the same position in the order, then the vocabularies of A and B are compared lexicographically. If this yields an unambiguous answer, comparison stops."
+    "If A and B belong to the same vocabulary, their names are compared lexicographically. This must yield an unambiguous result, since if the names equal they must be the same class and this case was already handled in the first step."
+}
+"Some examples:"
+{ $list
+    { { $link integer } " precedes " { $link number } " because it is a strict subset" }
+    { { $link number } " precedes " { $link sequence } " because the " { $vocab-link "math" } " vocabulary precedes the " { $vocab-link "sequences" } " vocabulary" }
+    { { $link crc32 } " precedes " { $link checksum } ", even if it were the only instance, because " { $link crc32 } " is a singleton class which is more specific than a mixin class" }
+}
+"Operations:"
+{ $subsection class<=> }
+{ $subsection sort-classes }
+"Metaclass order:"
+{ $subsection rank-class } ;
+
 HELP: flatten-builtin-class
 { $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
 { $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
@@ -29,14 +63,16 @@ HELP: class-types
 { $values { "class" class } { "seq" "an increasing sequence of integers" } }
 { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
 
-HELP: class<
+HELP: class<=
 { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 
 HELP: sort-classes
 { $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;
+
+{ sort-classes class<=> } related-words
 
 HELP: class-or
 { $values { "first" class } { "second" class } { "class" class } }
@@ -53,3 +89,7 @@ HELP: classes-intersect?
 HELP: min-class
 { $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
 { $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
+
+HELP: class<=>
+{ $values { "first" class } { "second" class } { "n" symbol } }
+{ $description "Compares two classes with the class linearization order." } ;

core/classes/algebra/algebra-tests.factor

@@ -4,9 +4,9 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects kernel.private sbufs ;
+random inference effects kernel.private sbufs math.order ;
 
-: class= [ class< ] 2keep swap class< and ;
+: class= [ class<= ] [ swap class<= ] 2bi and ;
 
 : class-and* >r class-and r> class= ;
 
@@ -38,43 +38,43 @@ UNION: both first-one union-class ;
 
 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
 
-[ t ] [ \ fixnum \ integer class< ] unit-test
+[ t ] [ \ fixnum \ integer class<= ] unit-test
-[ t ] [ \ fixnum \ fixnum class< ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
 
-[ t ] [ \ generic \ word class< ] unit-test
+[ t ] [ \ generic \ word class<= ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
 
-[ f ] [ \ reversed \ slice class< ] unit-test
+[ f ] [ \ reversed \ slice class<= ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
 
 PREDICATE: no-docs < word "documentation" word-prop not ;
 
 UNION: no-docs-union no-docs integer ;
 
-[ t ] [ no-docs no-docs-union class< ] unit-test
+[ t ] [ no-docs no-docs-union class<= ] unit-test
-[ f ] [ no-docs-union no-docs class< ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
 
 TUPLE: a ;
 TUPLE: b ;
 UNION: c a b ;
 
-[ t ] [ \ c \ tuple class< ] unit-test
+[ t ] [ \ c \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ c class< ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
 
-[ t ] [ \ tuple-class \ class class< ] unit-test
+[ t ] [ \ tuple-class \ class class<= ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
 
 TUPLE: tuple-example ;
 
-[ t ] [ \ null \ tuple-example class< ] unit-test
+[ t ] [ \ null \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ t ] [ \ tuple-example \ tuple class< ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ tuple-example class< ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
 
 TUPLE: a1 ;
 TUPLE: b1 ;
@@ -84,57 +84,57 @@ UNION: x1 a1 b1 ;
 UNION: y1 a1 c1 ;
 UNION: z1 b1 c1 ;
 
-[ f ] [ z1 x1 y1 class-and class< ] unit-test
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
 
-[ t ] [ x1 y1 class-and a1 class< ] unit-test
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
 
 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
 
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
 
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test
 
 [ t ] [
-    growable tuple sequence class-and class<
+    growable tuple sequence class-and class<=
 ] unit-test
 
 [ t ] [
-    growable assoc class-and tuple class<
+    growable assoc class-and tuple class<=
 ] unit-test
 
-[ t ] [ object \ f \ f class-not class-or class< ] unit-test
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
 
 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
 
 [ f ] [ integer integer class-not classes-intersect? ] unit-test
 
-[ t ] [ array number class-not class< ] unit-test
+[ t ] [ array number class-not class<= ] unit-test
 
-[ f ] [ bignum number class-not class< ] unit-test
+[ f ] [ bignum number class-not class<= ] unit-test
 
 [ vector ] [ vector class-not class-not ] unit-test
 
-[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class-and array class< ] unit-test
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
-[ f ] [ number class-not array class< ] unit-test
+[ f ] [ number class-not array class<= ] unit-test
 
-[ f ] [ fixnum class-not array class< ] unit-test
+[ f ] [ fixnum class-not array class<= ] unit-test
 
-[ t ] [ number class-not integer class-not class< ] unit-test
+[ t ] [ number class-not integer class-not class<= ] unit-test
 
 [ t ] [ vector array class-not class-and vector class= ] unit-test
 
 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
 [ t ] [ null class-not object class= ] unit-test
 
@@ -147,7 +147,7 @@ UNION: z1 b1 c1 ;
 [ t ] [
     fixnum class-not
     fixnum fixnum class-not class-or
-    class<
+    class<=
 ] unit-test
 
 ! Test method inlining
@@ -241,3 +241,14 @@ UNION: z1 b1 c1 ;
         =
     ] unit-test
 ] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number integer ratio } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+[ +lt+ ] [ \ real sequence class<=> ] unit-test

core/classes/algebra/algebra.factor

@@ -2,16 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes classes.builtin combinators accessors
 sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets ;
+math hashtables kernel.private sets math.order ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
     >r >r 2array r> [ first2 ] r> compose cache ; inline
 
-DEFER: (class<)
+DEFER: (class<=)
 
-: class< ( first second -- ? )
+: class<= ( first second -- ? )
-    class<-cache get [ (class<) ] 2cache ;
+    class<=-cache get [ (class<=) ] 2cache ;
 
 DEFER: (class-not)
 
@@ -45,31 +45,31 @@ TUPLE: anonymous-complement class ;
 
 C: <anonymous-complement> anonymous-complement
 
-: superclass< ( first second -- ? )
+: superclass<= ( first second -- ? )
-    >r superclass r> class< ;
+    >r superclass r> class<= ;
 
-: left-union-class< ( first second -- ? )
+: left-union-class<= ( first second -- ? )
-    >r members r> [ class< ] curry all? ;
+    >r members r> [ class<= ] curry all? ;
 
-: right-union-class< ( first second -- ? )
+: right-union-class<= ( first second -- ? )
-    members [ class< ] with contains? ;
+    members [ class<= ] with contains? ;
 
 : left-anonymous-union< ( first second -- ? )
-    >r members>> r> [ class< ] curry all? ;
+    >r members>> r> [ class<= ] curry all? ;
 
 : right-anonymous-union< ( first second -- ? )
-    members>> [ class< ] with contains? ;
+    members>> [ class<= ] with contains? ;
 
 : left-anonymous-intersection< ( first second -- ? )
-    >r members>> r> [ class< ] curry contains? ;
+    >r members>> r> [ class<= ] curry contains? ;
 
 : right-anonymous-intersection< ( first second -- ? )
-    members>> [ class< ] with all? ;
+    members>> [ class<= ] with all? ;
 
 : anonymous-complement< ( first second -- ? )
-    [ class>> ] bi@ swap class< ;
+    [ class>> ] bi@ swap class<= ;
 
-: (class<) ( first second -- -1/0/1 )  
+: (class<=) ( first second -- -1/0/1 )  
     {
         { [ 2dup eq? ] [ 2drop t ] }
         { [ dup object eq? ] [ 2drop t ] }
@@ -77,13 +77,13 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
         { [ over anonymous-union? ] [ left-anonymous-union< ] }
         { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over members ] [ left-union-class< ] }
+        { [ over members ] [ left-union-class<= ] }
         { [ dup anonymous-union? ] [ right-anonymous-union< ] }
         { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
         { [ over anonymous-complement? ] [ 2drop f ] }
         { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-        { [ dup members ] [ right-union-class< ] }
+        { [ dup members ] [ right-union-class<= ] }
-        { [ over superclass ] [ superclass< ] }
+        { [ over superclass ] [ superclass<= ] }
         [ 2drop f ]
     } cond ;
 
@@ -94,7 +94,7 @@ C: <anonymous-complement> anonymous-complement
     members>> [ classes-intersect? ] with all? ;
 
 : anonymous-complement-intersect? ( first second -- ? )
-    class>> class< not ;
+    class>> class<= not ;
 
 : union-class-intersect? ( first second -- ? )
     members [ classes-intersect? ] with contains? ;
@@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
     {
         { [ over tuple eq? ] [ 2drop t ] }
         { [ over builtin-class? ] [ 2drop f ] }
-        { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
+        { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
         [ swap classes-intersect? ]
     } cond ;
 
@@ -145,8 +145,8 @@ C: <anonymous-complement> anonymous-complement
 
 : (class-and) ( first second -- class )
     {
-        { [ 2dup class< ] [ drop ] }
+        { [ 2dup class<= ] [ drop ] }
-        { [ 2dup swap class< ] [ nip ] }
+        { [ 2dup swap class<= ] [ nip ] }
         { [ 2dup classes-intersect? not ] [ 2drop null ] }
         { [ dup members ] [ right-union-and ] }
         { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
@@ -165,8 +165,8 @@ C: <anonymous-complement> anonymous-complement
 
 : (class-or) ( first second -- class )
     {
-        { [ 2dup class< ] [ nip ] }
+        { [ 2dup class<= ] [ nip ] }
-        { [ 2dup swap class< ] [ drop ] }
+        { [ 2dup swap class<= ] [ drop ] }
         { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
         { [ over anonymous-union? ] [ left-anonymous-union-or ] }
         [ 2array <anonymous-union> ]
@@ -180,22 +180,43 @@ C: <anonymous-complement> anonymous-complement
         [ <anonymous-complement> ]
     } cond ;
 
-: largest-class ( seq -- n elt )
+: class< ( first second -- ? )
-    dup [
+    {
-        [ 2dup class< >r swap class< not r> and ]
+        { [ 2dup class<= not ] [ 2drop f ] }
-        with filter empty?
+        { [ 2dup swap class<= not ] [ 2drop t ] }
-    ] curry find [ "Topological sort failed" throw ] unless* ;
+        [ [ rank-class ] bi@ < ]
+    } cond ;
+
+: class-tie-breaker ( first second -- n )
+    2dup [ rank-class ] compare {
+        { +lt+ [ 2drop +lt+ ] }
+        { +gt+ [ 2drop +gt+ ] }
+        { +eq+ [ <=> ] }
+    } case ;
+
+: (class<=>) ( first second -- n )
+    {
+        { [ 2dup class<= ] [
+            2dup swap class<=
+            [ class-tie-breaker ] [ 2drop +lt+ ] if
+        ] }
+        { [ 2dup swap class<= ] [
+            2dup class<=
+            [ class-tie-breaker ] [ 2drop +gt+ ] if
+        ] }
+        [ class-tie-breaker ]
+    } cond ;
+
+: class<=> ( first second -- n )
+    class<=>-cache get [ (class<=>) ] 2cache ;
 
 : sort-classes ( seq -- newseq )
-    >vector
+    [ class<=> invert-comparison ] sort ;
-    [ dup empty? not ]
-    [ dup largest-class >r over delete-nth r> ]
-    [ ] unfold nip ;
 
 : min-class ( class seq -- class/f )
     over [ classes-intersect? ] curry filter
     dup empty? [ 2drop f ] [
-        tuck [ class< ] with all? [ peek ] [ drop f ] if
+        tuck [ class<= ] with all? [ peek ] [ drop f ] if
     ] if ;
 
 : (flatten-class) ( class -- )
@@ -212,7 +233,7 @@ C: <anonymous-complement> anonymous-complement
 
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
-        dup tuple class< [ 2drop tuple tuple ] when
+        dup tuple class<= [ 2drop tuple tuple ] when
     ] assoc-map ;
 
 : class-types ( class -- seq )

core/classes/builtin/builtin.factor

@@ -16,3 +16,5 @@ PREDICATE: builtin-class < class
 M: hi-tag class hi-tag type>class ;
 
 M: object class tag type>class ;
+
+M: builtin-class rank-class drop 0 ;

core/classes/classes-docs.factor

@@ -47,6 +47,7 @@ $nl
 $nl
 "Classes can be inspected and operated upon:"
 { $subsection "class-operations" }
+{ $subsection "class-linearization" }
 { $see-also "class-index" } ;
 
 ABOUT: "classes"

core/classes/classes-tests.factor

@@ -18,14 +18,14 @@ GENERIC: generic-update-test ( x -- y )
 
 M: union-1 generic-update-test drop "union-1" ;
 
-[ f ] [ bignum union-1 class< ] unit-test
+[ f ] [ bignum union-1 class<= ] unit-test
-[ t ] [ union-1 number class< ] unit-test
+[ t ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ 1.0 generic-update-test ] unit-test
 
 "IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
 
-[ t ] [ bignum union-1 class< ] unit-test
+[ t ] [ bignum union-1 class<= ] unit-test
-[ f ] [ union-1 number class< ] unit-test
+[ f ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
 
 "IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
@@ -52,7 +52,7 @@ M: sequence-mixin collection-size length ;
 
 M: assoc-mixin collection-size assoc-size ;
 
-[ t ] [ array sequence-mixin class< ] unit-test
+[ t ] [ array sequence-mixin class<= ] unit-test
 [ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
 [ 3 ] [ { 1 2 3 } collection-size ] unit-test
 [ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
@@ -67,14 +67,14 @@ MIXIN: mx1
 
 INSTANCE: integer mx1
 
-[ t ] [ integer mx1 class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class< ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
 
 "IN: classes.tests USE: arrays INSTANCE: array mx1" eval
 
-[ t ] [ array mx1 class< ] unit-test
+[ t ] [ array mx1 class<= ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
 
 [ \ mx1 forget ] with-compilation-unit
 
@@ -94,14 +94,14 @@ UNION: redefine-bug-1 fixnum ;
 
 UNION: redefine-bug-2 redefine-bug-1 quotation ;
 
-[ t ] [ fixnum redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ quotation redefine-bug-2 class<= ] unit-test
 
 [ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
 
-[ t ] [ bignum redefine-bug-1 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
 
 USE: io.streams.string
 

core/classes/classes.factor

@@ -5,21 +5,24 @@ slots.private namespaces sequences strings words vectors math
 quotations combinators sorting effects graphs vocabs ;
 IN: classes
 
-SYMBOL: class<-cache
+SYMBOL: class<=-cache
+SYMBOL: class<=>-cache
 SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
 SYMBOL: class-and-cache
 SYMBOL: class-or-cache
 
 : init-caches ( -- )
-    H{ } clone class<-cache set
+    H{ } clone class<=-cache set
+    H{ } clone class<=>-cache set
     H{ } clone class-not-cache set
     H{ } clone classes-intersect-cache set
     H{ } clone class-and-cache set
     H{ } clone class-or-cache set ;
 
 : reset-caches ( -- )
-    class<-cache get clear-assoc
+    class<=-cache get clear-assoc
+    class<=>-cache get clear-assoc
     class-not-cache get clear-assoc
     classes-intersect-cache get clear-assoc
     class-and-cache get clear-assoc
@@ -57,6 +60,8 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;
 
+GENERIC: rank-class ( class -- n )
+
 GENERIC: reset-class ( class -- )
 
 M: word reset-class drop ;

core/classes/mixin/mixin.factor

@@ -9,6 +9,8 @@ PREDICATE: mixin-class < union-class "mixin" word-prop ;
 M: mixin-class reset-class
     { "class" "metaclass" "members" "mixin" } reset-props ;
 
+M: mixin-class rank-class drop 3 ;
+
 : redefine-mixin-class ( class members -- )
     dupd define-union-class
     t "mixin" set-word-prop ;

core/classes/predicate/predicate.factor

@@ -30,3 +30,5 @@ M: predicate-class reset-class
         "predicate-definition"
         "superclass"
     } reset-props ;
+
+M: predicate-class rank-class drop 1 ;

core/classes/tuple/tuple-tests.factor

@@ -233,8 +233,8 @@ TUPLE: laptop < computer battery ;
 C: <laptop> laptop
 
 [ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
 [ t ] [ laptop computer classes-intersect? ] unit-test
 
 [ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
@@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ;
 C: <server> server
 
 [ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer class<= ] unit-test
 [ t ] [ server computer classes-intersect? ] unit-test
 
 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
@@ -286,8 +286,8 @@ test-server-slot-values
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
 
-[ f ] [ server laptop class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
-[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server class<= ] unit-test
 [ f ] [ laptop server classes-intersect? ] unit-test
 
 [ f ] [ 1 2 <computer> laptop? ] unit-test
@@ -306,9 +306,9 @@ TUPLE: electronic-device ;
 
 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
 
-[ f ] [ electronic-device laptop class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
-[ t ] [ server electronic-device class< ] unit-test
+[ t ] [ server electronic-device class<= ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ t ] [ laptop server class-or electronic-device class<= ] unit-test
 
 [ t ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test

core/classes/tuple/tuple.factor

@@ -226,6 +226,8 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
+M: tuple-class rank-class drop 0 ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 

core/classes/union/union.factor

@@ -30,3 +30,5 @@ M: union-class update-class define-union-predicate ;
 
 M: union-class reset-class
     { "class" "metaclass" "members" } reset-props ;
+
+M: union-class rank-class drop 2 ;

core/continuations/continuations-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel math namespaces io tools.test sequences vectors
 continuations debugger parser memory arrays words
-kernel.private ;
+kernel.private accessors ;
 IN: continuations.tests
 
 : (callcc1-test)
@@ -100,3 +100,20 @@ SYMBOL: error-counter
     [ 3 ] [ always-counter get ] unit-test
     [ 1 ] [ error-counter get ] unit-test
 ] with-scope
+
+TUPLE: dispose-error ;
+
+M: dispose-error dispose 3 throw ;
+
+TUPLE: dispose-dummy disposed? ;
+
+M: dispose-dummy dispose t >>disposed? drop ;
+
+T{ dispose-error } "a" set
+T{ dispose-dummy } "b" set
+
+[ f ] [ "b" get disposed?>> ] unit-test
+
+[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
+
+[ t ] [ "b" get disposed?>> ] unit-test

core/continuations/continuations.factor

@@ -138,6 +138,11 @@ SYMBOL: thread-error-hook
 
 GENERIC: dispose ( object -- )
 
+: dispose-each ( seq -- )
+    [
+        [ [ dispose ] curry [ , ] recover ] each
+    ] { } make dup empty? [ drop ] [ peek rethrow ] if ;
+
 : with-disposal ( object quot -- )
     over [ dispose ] curry [ ] cleanup ; inline
 

core/generator/registers/registers.factor

@@ -181,11 +181,11 @@ INSTANCE: constant value
 
 : %unbox-c-ptr ( dst src -- )
     dup operand-class {
-        { [ dup \ f class< ] [ drop %unbox-f ] }
+        { [ dup \ f class<= ] [ drop %unbox-f ] }
-        { [ dup simple-alien class< ] [ drop %unbox-alien ] }
+        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
-        { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
-        { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
-        { [ dup float-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup float-array class<= ] [ drop %unbox-byte-array ] }
         [ drop %unbox-any-c-ptr ]
     } cond ; inline
 
@@ -569,7 +569,7 @@ M: loc lazy-store
     {
         { f [ drop t ] }
         { known-tag [ class-tag >boolean ] }
-        [ class< ]
+        [ class<= ]
     } case ;
 
 : spec-matches? ( value spec -- ? )
@@ -644,7 +644,7 @@ PRIVATE>
 UNION: immediate fixnum POSTPONE: f ;
 
 : operand-immediate? ( operand -- ? )
-    operand-class immediate class< ;
+    operand-class immediate class<= ;
 
 : phantom-push ( obj -- )
     1 phantom-datastack get adjust-phantom

core/generic/generic-docs.factor

@@ -4,22 +4,22 @@ generic.standard generic.math combinators ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
-"Consider the case where a generic word has methods on two classes, say A and B, which share a non-empty intersection. If the generic word is called on an object which is an instance of both A and B, a choice of method must be made. If A is a subclass of B, the method for A to be called; this makes sense, because we're defining general behavior for instances of B, and refining it for instances of A. Conversely, if B is a subclass of A, then we expect B's method to be called. However, if neither is a subclass of the other, we have an ambiguous situation and undefined behavior will result. Either the method for A or B will be called, and there is no way to predict ahead of time."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
-$nl
-"The generic word system linearly orders all the methods on a generic word by their class. Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in order. If methods are defined on overlapping classes, this order will fail to be unique and the problem described above can occur."
 $nl
 "Here is an example:"
 { $code
     "GENERIC: explain"
-    "M: number explain drop \"an integer\" print ;"
-    "M: sequence explain drop \"a sequence\" print ;"
     "M: object explain drop \"an object\" print ;"
+    "M: number explain drop \"a number\" print ;"
+    "M: sequence explain drop \"a sequence\" print ;"
 }
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. As a result, the outcome of calling " { $snippet "bar" } " with an " { $link integer } " on the stack is undefined - either one of the two methods may be called. This situation can lead to subtle bugs. To avoid it, explicitly disambiguate the method order by defining a method on the intersection. If in this case we want integers to behave like numbers, we would also define:"
+"The linear order is the following, from least-specific to most-specific:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
+{ $code "{ object sequence number }" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
 { $code "M: integer explain drop \"a sequence\" print ;" }
-"The " { $link order } " word can be useful to clarify method dispatch order."
+"Now, the linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number integer }" }
+"The " { $link order } " word can be useful to clarify method dispatch order:"
 { $subsection order } ;
 
 ARTICLE: "generic-introspection" "Generic word introspection"

core/generic/generic.factor

@@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
 GENERIC: effective-method ( ... generic -- method )
 
 : next-method-class ( class generic -- class/f )
-    order [ class< ] with filter reverse dup length 1 =
+    order [ class<= ] with filter reverse dup length 1 =
     [ drop f ] [ second ] if ;
 
 : next-method ( class generic -- class/f )

core/generic/math/math.factor

@@ -10,14 +10,14 @@ PREDICATE: math-class < class
     dup null bootstrap-word eq? [
         drop f
     ] [
-        number bootstrap-word class<
+        number bootstrap-word class<=
     ] if ;
 
 : last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
 
 : math-precedence ( class -- pair )
     {
-        { [ dup null class< ] [ drop { -1 -1 } ] }
+        { [ dup null class<= ] [ drop { -1 -1 } ] }
         { [ dup math-class? ] [ class-types last/first ] }
         [ drop { 100 100 } ]
     } cond ;

core/generic/standard/engines/engines.factor

@@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
     alist>quot ;
 
 : split-methods ( assoc class -- first second )
-    [ [ nip class< not ] curry assoc-filter ]
+    [ [ nip class<= not ] curry assoc-filter ]
-    [ [ nip class<     ] curry assoc-filter ] 2bi ;
+    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
 
 : convert-methods ( assoc class word -- assoc' )
     over >r >r split-methods dup assoc-empty? [

core/generic/standard/engines/predicate/predicate.factor

@@ -11,7 +11,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
     [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
 
 : keep-going? ( assoc -- ? )
-    assumed get swap second first class< ;
+    assumed get swap second first class<= ;
 
 : prune-redundant-predicates ( assoc -- default assoc' )
     {

core/inference/class/class.factor

@@ -143,7 +143,7 @@ M: literal-constraint constraint-satisfied?
     [ swap literal>> eql? ] [ 2drop f ] if ;
 
 M: class-constraint constraint-satisfied?
-    [ value>> value-class* ] [ class>> ] bi class< ;
+    [ value>> value-class* ] [ class>> ] bi class<= ;
 
 M: pair apply-constraint
     first2 2dup constraints get set-at

core/io/crc32/crc32-docs.factor

@@ -1,17 +0,0 @@
-USING: help.markup help.syntax math ;
-IN: io.crc32
-
-HELP: crc32
-{ $values { "seq" "a sequence of bytes" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
-
-HELP: lines-crc32
-{ $values { "seq" "a sequence of strings" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
-
-ARTICLE: "io.crc32" "CRC32 checksum calculation"
-"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
-{ $subsection crc32 }
-{ $subsection lines-crc32 } ;
-
-ABOUT: "io.crc32"

core/io/crc32/crc32-tests.factor

@@ -1,5 +0,0 @@
-USING: io.crc32 kernel math tools.test namespaces ;
-
-[ 0 ] [ "" crc32 ] unit-test
-[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test
-

core/math/math.factor

@@ -80,9 +80,6 @@ M: number equal? number= ;
 
 M: real hashcode* nip >fixnum ;
 
-! real and sequence overlap. we disambiguate:
-M: integer hashcode* nip >fixnum ;
-
 GENERIC: fp-nan? ( x -- ? )
 
 M: object fp-nan?

core/math/order/order.factor

@@ -7,17 +7,13 @@ SYMBOL: +lt+
 SYMBOL: +eq+
 SYMBOL: +gt+
 
-GENERIC: <=> ( obj1 obj2 -- symbol )
-
-: (<=>) ( a b -- symbol )
-    2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
-
 : invert-comparison ( symbol -- new-symbol )
     #! Can't use case, index or nth here
     dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
 
-M: real <=> (<=>) ;
+GENERIC: <=> ( obj1 obj2 -- symbol )
-M: integer <=> (<=>) ;
+
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
 
 GENERIC: before? ( obj1 obj2 -- ? )
 GENERIC: after? ( obj1 obj2 -- ? )

core/optimizer/control/control.factor

@@ -154,9 +154,9 @@ SYMBOL: potential-loops
         node-literal t
     ] [
         node-class {
-            { [ dup null class< ] [ drop f f ] }
+            { [ dup null class<= ] [ drop f f ] }
-            { [ dup \ f class-not class< ] [ drop t t ] }
+            { [ dup \ f class-not class<= ] [ drop t t ] }
-            { [ dup \ f class< ] [ drop f t ] }
+            { [ dup \ f class<= ] [ drop f t ] }
             [ drop f f ]
         } cond
     ] if ;

core/optimizer/def-use/def-use-tests.factor

@@ -11,10 +11,6 @@ namespaces assocs kernel sequences math tools.test words ;
     dataflow compute-def-use drop compute-dead-literals keys
     [ value-literal ] map ;
 
-: subset? [ member? ] curry all? ;
-
-: set= 2dup subset? >r swap subset? r> and ;
-
 [ { [ + ] } ] [
     [ [ 1 2 3 ] [ + ] over drop drop ] kill-set
 ] unit-test

core/optimizer/inlining/inlining.factor

@@ -77,7 +77,7 @@ DEFER: (flat-length)
         float real
         complex number
         object
-    } [ class< ] with find nip ;
+    } [ class<= ] with find nip ;
 
 : inlining-math-method ( #call word -- quot/f )
     swap node-input-classes
@@ -111,7 +111,7 @@ DEFER: (flat-length)
 : comparable? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
     #! are disjoint, return t.
-    2dup class< >r classes-intersect? not r> or ;
+    2dup class<= >r classes-intersect? not r> or ;
 
 : optimize-predicate? ( #call -- ? )
     dup node-param "predicating" word-prop dup [
@@ -132,7 +132,7 @@ DEFER: (flat-length)
 
 : evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
-    node-class-first r> class< ;
+    node-class-first r> class<= ;
 
 : optimize-predicate ( #call -- node )
     #! If the predicate is followed by a branch we fold it

core/optimizer/known-words/known-words.factor

@@ -4,7 +4,7 @@ IN: optimizer.known-words
 USING: alien arrays generic hashtables inference.dataflow
 inference.class kernel assocs math math.private kernel.private
 sequences words parser vectors strings sbufs io namespaces
-assocs quotations sequences.private io.binary io.crc32
+assocs quotations sequences.private io.binary
 io.streams.string layouts splitting math.intervals
 math.floats.private classes.tuple classes.tuple.private classes
 classes.algebra optimizer.def-use optimizer.backend
@@ -126,8 +126,6 @@ sequences.private combinators ;
 
 \ >sbuf { string } "specializer" set-word-prop
 
-\ crc32 { string } "specializer" set-word-prop
-
 \ split, { string string } "specializer" set-word-prop
 
 \ memq? { array } "specializer" set-word-prop

core/optimizer/math/math.factor

@@ -96,7 +96,7 @@ optimizer.math.partial generic.standard system accessors ;
 
 : math-closure ( class -- newclass )
     { null fixnum bignum integer rational float real number }
-    [ class< ] with find nip number or ;
+    [ class<= ] with find nip number or ;
 
 : fits? ( interval class -- ? )
     "interval" word-prop dup
@@ -108,7 +108,7 @@ optimizer.math.partial generic.standard system accessors ;
     dup r> at swap or ;
 
 : won't-overflow? ( interval node -- ? )
-    node-in-d [ value-class* fixnum class< ] all?
+    node-in-d [ value-class* fixnum class<= ] all?
     swap fixnum fits? and ;
 
 : post-process ( class interval node -- classes intervals )
@@ -214,7 +214,7 @@ optimizer.math.partial generic.standard system accessors ;
 : twiddle-interval ( i1 -- i2 )
     dup [
         node get node-in-d
-        [ value-class* integer class< ] all?
+        [ value-class* integer class<= ] all?
         [ integral-closure ] when
     ] when ;
 
@@ -293,7 +293,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 ! Removing overflow checks
 : remove-overflow-check? ( #call -- ? )
     dup out-d>> first node-class
-    [ fixnum class< ] [ null eq? not ] bi and ;
+    [ fixnum class<= ] [ null eq? not ] bi and ;
 
 {
     { + [ fixnum+fast ] }
@@ -356,7 +356,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     dup #call? [ node-param eq? ] [ 2drop f ] if ;
 
 : coerced-to-fixnum? ( #call -- ? )
-    dup dup node-in-d [ node-class integer class< ] with all?
+    dup dup node-in-d [ node-class integer class<= ] with all?
     [ \ >fixnum consumed-by? ] [ drop f ] if ;
 
 {
@@ -377,7 +377,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 : convert-rem-to-and? ( #call -- ? )
     dup node-in-d {
-        { [ 2dup first node-class integer class< not ] [ f ] }
+        { [ 2dup first node-class integer class<= not ] [ f ] }
         { [ 2dup second node-literal integer? not ] [ f ] }
         { [ 2dup second node-literal power-of-2? not ] [ f ] }
         [ t ]

core/optimizer/pattern-match/pattern-match.factor

@@ -12,7 +12,7 @@ SYMBOL: @
     @ get [ eq? ] [ @ set t ] if* ;
 
 : match-class ( value spec -- ? )
-    >r node get swap node-class r> class< ;
+    >r node get swap node-class r> class<= ;
 
 : value-match? ( value spec -- ? )
     {

core/parser/parser-tests.factor

@@ -432,3 +432,6 @@ must-fail-with
 ] must-fail
 
 [ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
+
+[ 92 ] [ "CHAR: \\" eval ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval ] unit-test

core/parser/parser.factor

@@ -421,14 +421,17 @@ ERROR: bad-number ;
 SYMBOL: current-class
 SYMBOL: current-generic
 
-: (M:)
+: with-method-definition ( quot -- parsed )
-    CREATE-METHOD
     [
+        >r
         [ "method-class" word-prop current-class set ]
         [ "method-generic" word-prop current-generic set ]
         [ ] tri
-        parse-definition
+        r> call
-    ] with-scope ;
+    ] with-scope ; inline
+
+: (M:)
+    CREATE-METHOD [ parse-definition ] with-method-definition ;
 
 : scan-object ( -- object )
     scan-word dup parsing?

core/prettyprint/backend/backend.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays bit-arrays generic hashtables io
+USING: arrays byte-arrays byte-vectors bit-arrays generic
-assocs kernel math namespaces sequences strings sbufs io.styles
+hashtables io assocs kernel math namespaces sequences strings
-vectors words prettyprint.config prettyprint.sections quotations
+sbufs io.styles vectors words prettyprint.config
-io io.files math.parser effects classes.tuple math.order
+prettyprint.sections quotations io io.files math.parser effects
-classes.tuple.private classes float-arrays ;
+classes.tuple math.order classes.tuple.private classes
+float-arrays ;
 IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
@@ -140,6 +141,7 @@ M: compose pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
 M: byte-array pprint-delims drop \ B{ \ } ;
 M: bit-array pprint-delims drop \ ?{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
 M: float-array pprint-delims drop \ F{ \ } ;
 M: vector pprint-delims drop \ V{ \ } ;
 M: hashtable pprint-delims drop \ H{ \ } ;
@@ -152,6 +154,7 @@ GENERIC: >pprint-sequence ( obj -- seq )
 M: object >pprint-sequence ;
 
 M: vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
 M: curry >pprint-sequence ;
 M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;

core/sets/sets-docs.factor

@@ -2,7 +2,7 @@ USING: kernel help.markup help.syntax sequences ;
 IN: sets
 
 ARTICLE: "sets" "Set-theoretic operations on sequences"
-"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
 $nl
 "Remove duplicates:"
 { $subsection prune }
@@ -12,8 +12,14 @@ $nl
 { $subsection diff }
 { $subsection intersect }
 { $subsection union }
+{ $subsection subset? }
+{ $subsection set= }
+"A word used to implement the above:"
+{ $subsection unique }
 { $see-also member? memq? contains? all? "assocs-sets" } ;
 
+ABOUT: "sets"
+
 HELP: unique
 { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
 { $description "Outputs a new assoc where the keys and values are equal." }
@@ -59,3 +65,11 @@ HELP: union
 } ;
 
 { diff intersect union } related-words
+
+HELP: subset?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+
+HELP: set=
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;

core/sets/sets.factor

@@ -29,3 +29,9 @@ IN: sets
 
 : union ( seq1 seq2 -- newseq )
     append prune ;
+
+: subset? ( seq1 seq2 -- ? )
+    unique [ key? ] curry all? ;
+
+: set= ( seq1 seq2 -- ? )
+    [ unique ] bi@ = ;

core/source-files/source-files.factor

@@ -3,8 +3,8 @@
 USING: arrays definitions generic assocs kernel math namespaces
 prettyprint sequences strings vectors words quotations inspector
 io.styles io combinators sorting splitting math.parser effects
-continuations debugger io.files io.crc32 vocabs hashtables
+continuations debugger io.files checksums checksums.crc32 vocabs
-graphs compiler.units io.encodings.utf8 accessors ;
+hashtables graphs compiler.units io.encodings.utf8 accessors ;
 IN: source-files
 
 SYMBOL: source-files
@@ -15,7 +15,7 @@ checksum
 uses definitions ;
 
 : record-checksum ( lines source-file -- )
-    >r lines-crc32 r> set-source-file-checksum ;
+    >r crc32 checksum-lines r> set-source-file-checksum ;
 
 : (xref-source) ( source-file -- pathname uses )
     dup source-file-path <pathname>

core/syntax/syntax.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays
+USING: alien arrays bit-arrays byte-arrays byte-vectors
 definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
@@ -79,6 +79,7 @@ IN: bootstrap.syntax
     "{" [ \ } [ >array ] parse-literal ] define-syntax
     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
+    "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
     "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
     "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax

extra/bank/authors.txt

@@ -0,0 +1 @@
+Alex Chapman

extra/bank/bank-tests.factor

@@ -0,0 +1,34 @@
+USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
+IN: bank.tests
+
+SYMBOL: my-account
+[
+    "Alex's Take Over the World Fund" 0.07 1 2007 11 1 <date> 6101.94 open-account my-account set
+    [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+    [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+    "Petty Cash" 0.07 1 2006 12 1 <date> 10962.18 open-account my-account set
+    [ 11027 ] [ my-account get 2007 1 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+    "Saving to buy a pony" 0.0725 1 2008 3 3 <date> 11106.24 open-account my-account set
+    [ 8416 ] [
+            my-account get [
+               2008 3 11 <date> -750 "Need to buy food" <transaction> ,
+               2008 3 25 <date> -500 "Going to a party" <transaction> ,
+               2008 4  8 <date> -800 "Losing interest in the pony..." <transaction> ,
+               2008 4  8 <date> -700 "Buying a rocking horse" <transaction> ,
+            ] { } make inserting-transactions balance>> round >integer
+        ] unit-test
+] with-scope
+
+[
+    [ 6781 ] [
+        "..." 0.07 1 2007 4 10 <date> 4398.50 open-account
+        2007 10 26 <date> 2000 "..." <transaction> 1array inserting-transactions
+        2008 4 10 <date> process-to-date dup balance>> swap unpaid-interest>> + round >integer
+    ] unit-test
+] with-scope

extra/bank/bank.factor

@@ -0,0 +1,69 @@
+USING: accessors calendar kernel math math.order money sequences ;
+IN: bank
+
+TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
+
+: <account> ( name interest-rate interest-payment-day opening-date -- account )
+    V{ } clone 0 pick account boa ;
+
+TUPLE: transaction date amount description ;
+C: <transaction> transaction
+
+: >>transaction ( account transaction -- account )
+    over transactions>> push ;
+
+: total ( transactions -- balance )
+    0 [ amount>> + ] reduce ;
+
+: balance>> ( account -- balance ) transactions>> total ;
+
+: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
+    >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+
+: daily-rate ( yearly-rate day -- daily-rate )
+    days-in-year / ;
+
+: daily-rate>> ( account date -- rate )
+    [ interest-rate>> ] dip daily-rate ;
+
+: before? ( date date -- ? ) <=> 0 < ;
+
+: transactions-on-date ( account date -- transactions )
+    [ before? ] curry filter ;
+
+: balance-on-date ( account date -- balance )
+    transactions-on-date total ;
+
+: pay-interest ( account date -- )
+    over unpaid-interest>> "Interest Credit" <transaction>
+    >>transaction 0 >>unpaid-interest drop ;
+
+: interest-payment-day? ( account date -- ? )
+    day>> swap interest-payment-day>> = ;
+
+: ?pay-interest ( account date -- )
+    2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
+
+: unpaid-interest+ ( account amount -- account )
+    over unpaid-interest>> + >>unpaid-interest ;
+
+: accumulate-interest ( account date -- )
+    [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
+    >>interest-last-paid drop ;
+
+: process-day ( account date -- )
+    2dup accumulate-interest ?pay-interest ;
+
+: each-day ( quot start end -- )
+    2dup before? [
+        >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+    ] [
+        3drop
+    ] if ;
+
+: process-to-date ( account date -- account )
+    over interest-last-paid>> 1 days time+
+    [ dupd process-day ] spin each-day ;
+
+: inserting-transactions ( account transactions -- account )
+    [ [ date>> process-to-date ] keep >>transaction ] each ;

extra/bank/summary.txt

@@ -0,0 +1 @@
+Bank account simulator for compound interest calculated daily and paid monthly

extra/benchmark/crc32/crc32.factor

@@ -1,10 +1,10 @@
-USING: io.crc32 io.encodings.ascii io.files kernel math ;
+USING: checksums checksums.crc32 io.encodings.ascii io.files kernel math ;
 IN: benchmark.crc32
 
 : crc32-primes-list ( -- )
     10 [
-        "extra/math/primes/list/list.factor" resource-path
+        "resource:extra/math/primes/list/list.factor"
-        ascii file-contents crc32 drop
+        crc32 checksum-file drop
     ] times ;
 
 MAIN: crc32-primes-list

extra/benchmark/md5/md5.factor

@@ -1,7 +1,7 @@
-USING: crypto.md5 io.files kernel ;
+USING: checksums checksums.md5 io.files kernel ;
 IN: benchmark.md5
 
 : md5-primes-list ( -- )
-    "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+    "resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
 
 MAIN: md5-primes-list

extra/benchmark/reverse-complement/reverse-complement-tests.factor

@@ -1,13 +1,13 @@
 IN: benchmark.reverse-complement.tests
-USING: tools.test benchmark.reverse-complement crypto.md5
+USING: tools.test benchmark.reverse-complement
+checksums checksums.md5
 io.files kernel ;
 
 [ "c071aa7e007a9770b2fb4304f55a17e5" ] [
-    "extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
+    "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
-    "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
+    "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
-    [ resource-path ] bi@
     reverse-complement
 
-    "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
+    "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
-    resource-path file>md5str
+    md5 checksum-file hex-string
 ] unit-test

extra/benchmark/sha1/sha1.factor

@@ -1,7 +1,7 @@
-USING: crypto.sha1 io.files kernel ;
+USING: checksums checksums.sha1 io.files kernel ;
 IN: benchmark.sha1
 
 : sha1-primes-list ( -- )
-    "extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
+    "resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
 
 MAIN: sha1-primes-list

extra/bootstrap/image/download/download.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: bootstrap.image.download
-USING: http.client crypto.md5 splitting assocs kernel io.files
+USING: http.client checksums checksums.md5 splitting assocs
-bootstrap.image sequences io ;
+kernel io.files bootstrap.image sequences io ;
 
 : url "http://factorcode.org/images/latest/" ;
 
@@ -12,7 +12,7 @@ bootstrap.image sequences io ;
 
 : need-new-image? ( image -- ? )
     dup exists?
-    [ dup file>md5str swap download-checksums at = not ]
+    [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
     [ drop t ] if ;
 
 : download-image ( arch -- )

extra/bootstrap/image/upload/upload.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: http.client checksums checksums.md5 splitting assocs
+kernel io.files bootstrap.image sequences io namespaces
+io.launcher math io.encodings.ascii ;
 IN: bootstrap.image.upload
-USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
 
 SYMBOL: upload-images-destination
 
@@ -17,7 +18,9 @@ SYMBOL: upload-images-destination
 
 : compute-checksums ( -- )
     checksums ascii [
-        boot-image-names [ dup write bl file>md5str print ] each
+        boot-image-names [
+            [ write bl ] [ md5 checksum-file hex-string print ] bi
+        ] each
     ] with-file-writer ;
 
 : upload-images ( -- )

extra/checksums/md5/md5-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.md5
+
+HELP: md5
+{ $description "MD5 checksum algorithm." } ;
+
+ARTICLE: "checksums.md5" "MD5 checksum"
+"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."
+{ $subsection md5 } ;
+
+ABOUT: "checksums.md5"

extra/checksums/md5/md5-tests.factor

@@ -0,0 +1,10 @@
+USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
+
+[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
+

extra/checksums/md5/md5.factor

@@ -3,8 +3,8 @@
 USING: kernel io io.binary io.files io.streams.byte-array math
 math.functions math.parser namespaces splitting strings
 sequences crypto.common byte-arrays locals sequences.private
-io.encodings.binary symbols math.bitfields.lib ;
+io.encodings.binary symbols math.bitfields.lib checksums ;
-IN: crypto.md5
+IN: checksums.md5
 
 <PRIVATE
 
@@ -166,26 +166,18 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
         [ (process-md5-block) ] each
     ] if ;
     
-: (stream>md5) ( -- )
+: stream>md5 ( -- )
     64 read [ process-md5-block ] keep
-    length 64 = [ (stream>md5) ] when ;
+    length 64 = [ stream>md5 ] when ;
 
 : get-md5 ( -- str )
     [ a b c d ] [ get 4 >le ] map concat >byte-array ;
 
 PRIVATE>
 
-: stream>md5 ( stream -- byte-array )
+SINGLETON: md5
-    [ initialize-md5 (stream>md5) get-md5 ] with-stream ;
 
-: byte-array>md5 ( byte-array -- checksum )
+INSTANCE: md5 checksum
-    binary <byte-reader> stream>md5 ;
 
-: byte-array>md5str ( byte-array -- md5-string )
+M: md5 checksum-stream ( stream -- byte-array )
-    byte-array>md5 hex-string ;
+    drop [ initialize-md5 stream>md5 get-md5 ] with-stream ;
-
-: file>md5 ( path -- byte-array )
-    binary <file-reader> stream>md5 ;
-
-: file>md5str ( path -- md5-string )
-    file>md5 hex-string ;

extra/checksums/null/null.factor

@@ -0,0 +1,8 @@
+USING: checksums ;
+IN: checksums.null
+
+SINGLETON: null
+
+INSTANCE: null checksum
+
+M: null checksum-bytes ;

extra/checksums/sha1/sha1-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.sha1
+
+HELP: sha1
+{ $description "SHA1 checksum algorithm." } ;
+
+ARTICLE: "checksums.sha1" "SHA1 checksum"
+"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
+{ $subsection sha1 } ;
+
+ABOUT: "checksums.sha1"

extra/checksums/sha1/sha1-tests.factor

@@ -1,14 +1,14 @@
-USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
+USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
 
-[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
-[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
 ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
 [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
-10 swap <array> concat byte-array>sha1str ] unit-test
+10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
 
 [
     ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
 ] [
     "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
-    byte-array>sha1-interleave
+    sha1-interleave
 ] unit-test

extra/checksums/sha1/sha1.factor

@@ -1,8 +1,8 @@
 USING: arrays combinators crypto.common kernel io
 io.encodings.binary io.files io.streams.byte-array math.vectors
 strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols math.bitfields.lib ;
+io.binary hashtables symbols math.bitfields.lib checksums ;
-IN: crypto.sha1
+IN: checksums.sha1
 
 ! Implemented according to RFC 3174.
 
@@ -99,30 +99,22 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
         [ (process-sha1-block) ] each
     ] if ;
 
-: (stream>sha1) ( -- )
+: stream>sha1 ( -- )
     64 read [ process-sha1-block ] keep
-    length 64 = [ (stream>sha1) ] when ;
+    length 64 = [ stream>sha1 ] when ;
 
 : get-sha1 ( -- str )
     [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
 
-: stream>sha1 ( stream -- sha1 )
+SINGLETON: sha1
-    [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
 
-: byte-array>sha1 ( string -- sha1 )
+INSTANCE: sha1 checksum
-    binary <byte-reader> stream>sha1 ;
 
-: byte-array>sha1str ( string -- str )
+M: sha1 checksum-stream ( stream -- sha1 )
-    byte-array>sha1 hex-string ;
+    drop [ initialize-sha1 stream>sha1 get-sha1 ] with-stream ;
 
-: byte-array>sha1-bignum ( string -- n )
+: sha1-interleave ( string -- seq )
-    byte-array>sha1 be> ;
-
-: file>sha1 ( file -- sha1 )
-    binary <file-reader> stream>sha1 ;
-
-: byte-array>sha1-interleave ( string -- seq )
     [ zero? ] left-trim
     dup length odd? [ rest ] when
-    seq>2seq [ byte-array>sha1 ] bi@
+    seq>2seq [ sha1 checksum-bytes ] bi@
     2seq>seq ;

extra/checksums/sha2/sha2-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.sha2
+
+HELP: sha-256
+{ $description "SHA-256 checksum algorithm." } ;
+
+ARTICLE: "checksums.sha2" "SHA2 checksum"
+"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
+{ $subsection sha-256 } ;
+
+ABOUT: "checksums.sha2"

extra/checksums/sha2/sha2-tests.factor

@@ -1,7 +1,7 @@
-USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
+USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test

extra/checksums/sha2/sha2.factor

@@ -1,6 +1,6 @@
 USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols math.bitfields.lib ;
+io.binary symbols math.bitfields.lib checksums ;
-IN: crypto.sha2
+IN: checksums.sha2
 
 <PRIVATE
 
@@ -118,14 +118,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
 
 PRIVATE>
 
-: byte-array>sha-256 ( string -- string )
+SINGLETON: sha-256
-    [
+
+INSTANCE: sha-256 checksum
+
+M: sha-256 checksum-bytes
+    drop [
         K-256 K set
         initial-H-256 H set
         4 word-size set
         64 block-size set
         byte-array>sha2
     ] with-scope ;
-
-: byte-array>sha-256-string ( string -- hexstring )
-    byte-array>sha-256 hex-string ;

extra/crypto/common/common-docs.factor

@@ -1,13 +0,0 @@
-USING: help.markup help.syntax kernel math sequences quotations
-math.private ;
-IN: crypto.common
-
-HELP: hex-string
-{ $values { "seq" "a sequence" } { "str" "a string" } }
-{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
-{ $examples
-    { $example "USING: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
-}
-{ $notes "Numbers are zero-padded on the left." } ;
-
-

extra/crypto/common/common.factor

@@ -1,5 +1,6 @@
 USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints math.bitfields.lib ;
+namespaces math math.parser parser hints math.bitfields.lib
+assocs ;
 IN: crypto.common
 
 : w+ ( int int -- int ) + 32 bits ; inline
@@ -39,9 +40,6 @@ SYMBOL: big-endian?
 : update-old-new ( old new -- )
     [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
 
-: hex-string ( seq -- str )
-    [ [ >hex 2 48 pad-left % ] each ] "" make ;
-
 : slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
 
 : seq>2seq ( seq -- seq1 seq2 )
@@ -50,7 +48,7 @@ SYMBOL: big-endian?
 
 : 2seq>seq ( seq1 seq2 -- seq )
     #! { aceg } { bdfh } -> { abcdefgh }
-    [ 2array flip concat ] keep like ;
+    [ zip concat ] keep like ;
 
 : mod-nth ( n seq -- elt )
     #! 5 "abcd" -> b

extra/crypto/hmac/hmac.factor

@@ -1,18 +1,19 @@
-USING: arrays combinators crypto.common crypto.md5 crypto.sha1
+USING: arrays combinators crypto.common checksums checksums.md5
-crypto.md5.private io io.binary io.files io.streams.byte-array
+checksums.sha1 checksums.md5.private io io.binary io.files
-kernel math math.vectors memoize sequences io.encodings.binary ;
+io.streams.byte-array kernel math math.vectors memoize sequences
+io.encodings.binary ;
 IN: crypto.hmac
 
 : sha1-hmac ( Ko Ki -- hmac )
     initialize-sha1 process-sha1-block
-    (stream>sha1) get-sha1
+    stream>sha1 get-sha1
     initialize-sha1
     >r process-sha1-block r>
     process-sha1-block get-sha1 ;
 
 : md5-hmac ( Ko Ki -- hmac )
     initialize-md5 process-md5-block
-    (stream>md5) get-md5
+    stream>md5 get-md5
     initialize-md5
     >r process-md5-block r>
     process-md5-block get-md5 ;

extra/crypto/md5/md5-docs.factor

@@ -1,18 +0,0 @@
-USING: help.markup help.syntax kernel math sequences quotations
-crypto.common byte-arrays ;
-IN: crypto.md5
-
-HELP: stream>md5
-{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
-{ $description "Take the MD5 hash until end of stream." }
-{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ".  Call " { $link hex-string } " to convert to the canonical string representation." } ;
-
-HELP: byte-array>md5
-{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
-{ $description "Outputs the MD5 hash of a byte array." }
-{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
-
-HELP: file>md5
-{ $values { "path" "a path" } { "byte-array" "byte-array md5 hash" } }
-{ $description "Outputs the MD5 hash of a file." }
-{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;

extra/crypto/md5/md5-tests.factor

@@ -1,10 +0,0 @@
-USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
-
-[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
-[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
-[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
-[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
-[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
-[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
-[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test
-

extra/csv/csv-tests.factor

@@ -47,8 +47,6 @@ IN: csv.tests
    <string-reader> csv ] named-unit-test
 
 
-
-   
 ! !!!!!!!!  other tests
    
 [ { { "Phil Dawes" } } ] 
@@ -65,3 +63,8 @@ IN: csv.tests
 "allows setting of delimiting character"
 [ { { "foo" "bah" "baz" } } ] 
 [ "foo\tbah\tbaz\n" <string-reader> CHAR: \t [ csv ] with-delimiter ] named-unit-test
+
+"Quoted field followed immediately by newline"
+[ { { "foo" "bar" }
+    { "1"   "2" } } ]
+[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test

extra/csv/csv.factor

@@ -31,6 +31,7 @@ VAR: delimiter
   read1 dup 
   { { CHAR: "    [ , quoted-field ] }  ! " is an escaped quote
     { delimiter> [ ] }                 ! end of quoted field 
+    { CHAR: \n   [ ] }
     [ 2drop skip-to-field-end ]       ! end of quoted field + padding
   } case ;
   

extra/db/pooling/pooling-tests.factor

@@ -0,0 +1,8 @@
+IN: db.pooling.tests
+USING: db.pooling tools.test ;
+
+\ <pool> must-infer
+
+{ 2 0 } [ [ ] with-db-pool ] must-infer-as
+
+{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as

extra/db/pooling/pooling.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel arrays namespaces sequences continuations
+destructors db ;
+IN: db.pooling
+
+TUPLE: pool db params connections ;
+
+: <pool> ( db params -- pool )
+    V{ } clone pool boa ;
+
+M: pool dispose [ dispose-each f ] change-connections drop ;
+
+: with-db-pool ( db params quot -- )
+    >r <pool> r> [ pool swap with-variable ] curry with-disposal ; inline
+
+TUPLE: return-connection db pool ;
+
+: return-connection ( db pool -- )
+    connections>> push ;
+
+: new-connection ( pool -- )
+    [ [ db>> ] [ params>> ] bi make-db db-open ] keep
+    return-connection ;
+
+: acquire-connection ( pool -- db )
+    [ dup connections>> empty? ] [ dup new-connection ] [ ] while
+    connections>> pop ;
+
+: (with-pooled-connection) ( db pool quot -- )
+    [ >r drop db r> with-variable ]
+    [ drop return-connection ]
+    3bi ; inline
+
+: with-pooled-connection ( pool quot -- )
+    >r [ acquire-connection ] keep r>
+    [ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
+
+M: return-connection dispose
+    [ db>> ] [ pool>> ] bi return-connection ;
+
+: return-connection-later ( db pool -- )
+    \ return-connection boa add-always-destructor ;

extra/delegate/delegate-docs.factor

@@ -24,30 +24,17 @@ HELP: CONSULT:
 
 { define-consult POSTPONE: CONSULT: } related-words
 
-HELP: define-mimic
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
-{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
-
-HELP: MIMIC:
-{ $syntax "MIMIC: group mimicker mimicked" }
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
-
 HELP: group-words
 { $values { "group" "a group" } { "words" "an array of words" } }
-{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
+{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
 
 ARTICLE: { "delegate" "intro" } "Delegation module"
-"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
+"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
 { $subsection POSTPONE: PROTOCOL: }
 { $subsection define-protocol }
 "One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
 { $subsection POSTPONE: CONSULT: }
-{ $subsection define-consult }
+{ $subsection define-consult } ;
-"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
-{ $subsection POSTPONE: MIMIC: }
-{ $subsection define-mimic } ;
 
 IN: delegate
 ABOUT: { "delegate" "intro" }

extra/delegate/delegate-tests.factor

@@ -2,11 +2,6 @@ USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string ;
 IN: delegate.tests
 
-DEFER: example
-[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
-[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
-[ 2 ] [ \ example "prop" word-prop ] unit-test
-
 TUPLE: hello this that ;
 C: <hello> hello
 
@@ -30,21 +25,19 @@ GENERIC: bing ( c -- d )
 PROTOCOL: bee bing ;
 CONSULT: hello goodbye goodbye-those ;
 M: hello bing hello-test ;
-MIMIC: bee goodbye hello
 
 [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
 [ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
 [ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
 [ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
 [ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
-[ V{ goodbye } ] [ baz protocol-users ] unit-test
+[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
+[ H{ } ] [ bee protocol-consult ] unit-test
 
-! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
-! [ [ baz see ] with-string-writer ] unit-test
 
 ! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
 ! [ f ] [ goodbye baz method ] unit-test

extra/delegate/delegate.factor

@@ -1,9 +1,44 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint combinators.lib math sets ;
+vectors definitions prettyprint combinators.lib math hashtables sets ;
 IN: delegate
 
+: protocol-words ( protocol -- words )
+    \ protocol-words word-prop ;
+
+: protocol-consult ( protocol -- consulters )
+    \ protocol-consult word-prop ;
+
+GENERIC: group-words ( group -- words )
+
+M: tuple-class group-words
+    "slot-names" word-prop [
+        [ reader-word ] [ writer-word ] bi
+        2array [ 0 2array ] map
+    ] map concat ;
+
+! Consultation
+
+: consult-method ( word class quot -- )
+    [ drop swap first create-method ]
+    [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
+
+: change-word-prop ( word prop quot -- )
+    rot word-props swap change-at ; inline
+
+: register-protocol ( group class quot -- )
+    rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
+
+: define-consult ( group class quot -- )
+    [ register-protocol ] [
+        rot group-words -rot
+        [ consult-method ] 2curry each
+    ] 3bi ;
+
+: CONSULT:
+    scan-word scan-word parse-definition define-consult ; parsing
+
 ! Protocols
 
 : cross-2each ( seq1 seq2 quot -- )
@@ -12,36 +47,46 @@ IN: delegate
 : forget-all-methods ( classes words -- )
     [ 2array forget ] cross-2each ;
 
-: protocol-words ( protocol -- words )
-    "protocol-words" word-prop ;
-
 : protocol-users ( protocol -- users )
-    "protocol-users" word-prop ;
+    protocol-consult keys ;
 
-: users-and-words ( protocol -- users words )
+: lost-words ( protocol wordlist -- lost-words )
-    [ protocol-users ] [ protocol-words ] bi ;
+    >r protocol-words r> diff ;
 
 : forget-old-definitions ( protocol new-wordlist -- )
-    >r users-and-words r>
+    >r [ protocol-users ] [ protocol-words ] bi r>
     swap diff forget-all-methods ;
 
-: define-protocol ( protocol wordlist -- )
+: added-words ( protocol wordlist -- added-words )
-    ! 2dup forget-old-definitions
+    swap protocol-words swap diff ;
-    { } like "protocol-words" set-word-prop ;
+
+: add-new-definitions ( protocol wordlist -- )
+     dupd added-words >r protocol-consult >alist r>
+     [ first2 consult-method ] cross-2each ;
+
+: initialize-protocol-props ( protocol wordlist -- )
+    [ drop H{ } clone \ protocol-consult set-word-prop ]
+    [ { } like \ protocol-words set-word-prop ] 2bi ;
 
 : fill-in-depth ( wordlist -- wordlist' )
     [ dup word? [ 0 2array ] when ] map ;
 
+: define-protocol ( protocol wordlist -- )
+    fill-in-depth
+    [ forget-old-definitions ]
+    [ add-new-definitions ]
+    [ initialize-protocol-props ] 2tri ;
+
 : PROTOCOL:
     CREATE-WORD
-    dup define-symbol
+    [ define-symbol ]
-    dup f "inline" set-word-prop
+    [ f "inline" set-word-prop ]
-    parse-definition fill-in-depth define-protocol ; parsing
+    [ parse-definition define-protocol ] tri ; parsing
 
 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
 
 M: protocol forget*
-    [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+    [ f forget-old-definitions ] [ call-next-method ] bi ;
 
 : show-words ( wordlist' -- wordlist )
     [ dup second zero? [ first ] when ] map ;
@@ -52,51 +97,4 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
 
 M: protocol synopsis* word-synopsis ; ! Necessary?
 
-GENERIC: group-words ( group -- words )
+M: protocol group-words protocol-words ;
-
-M: protocol group-words
-    "protocol-words" word-prop ;
-
-M: tuple-class group-words
-    "slot-names" word-prop [
-        [ reader-word ] [ writer-word ] bi
-        2array [ 0 2array ] map
-    ] map concat ;
-
-! Consultation
-
-: define-consult-method ( word class quot -- )
-    [ drop swap first create-method ]
-    [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
-
-: change-word-prop ( word prop quot -- )
-    >r swap word-props r> change-at ; inline
-
-: add ( item vector/f -- vector )
-    2dup member? [ nip ] [ ?push ] if ;
-
-: use-protocol ( class group -- )
-    "protocol-users" [ add ] change-word-prop ;
-
-: define-consult ( group class quot -- )
-    swapd >r 2dup use-protocol group-words swap r>
-    [ define-consult-method ] 2curry each ;
-
-: CONSULT:
-    scan-word scan-word parse-definition define-consult ; parsing
-
-! Mimic still needs to be updated
-
-: mimic-method ( mimicker mimicked generic -- )
-    tuck method 
-    [ [ create-method-in ] [ word-def ] bi* define ]
-    [ 2drop ] if* ;
-
-: define-mimic ( group mimicker mimicked -- )
-    [ drop swap use-protocol ] [
-        rot group-words -rot
-        [ rot first mimic-method ] 2curry each
-    ] 3bi ;
-
-: MIMIC:
-    scan-word scan-word scan-word define-mimic ; parsing

extra/destructors/destructors.factor

@@ -26,14 +26,11 @@ M: destructor dispose
 : add-always-destructor ( obj -- )
     <destructor> always-destructors get push ;
 
-: dispose-each ( seq -- )
-    <reversed> [ dispose ] each ;
-
 : do-always-destructors ( -- )
-    always-destructors get dispose-each ;
+    always-destructors get <reversed> dispose-each ;
 
 : do-error-destructors ( -- )
-    error-destructors get dispose-each ;
+    error-destructors get <reversed> dispose-each ;
 
 : with-destructors ( quot -- )
     [

extra/farkup/farkup.factor

@@ -63,8 +63,14 @@ MEMO: eq ( -- parser )
         ] with-html-stream
     ] with-string-writer ;
 
+: check-url ( href -- href' )
+    CHAR: : over member? [
+        dup { "http://" "https://" "ftp://" } [ head? ] with contains?
+        [ drop "/" ] unless
+    ] when ;
+
 : escape-link ( href text -- href-esc text-esc )
-    >r escape-quoted-string r> escape-string ;
+    >r check-url escape-quoted-string r> escape-string ;
 
 : make-link ( href text -- seq )
     escape-link

extra/help/handbook/handbook.factor

@@ -204,7 +204,8 @@ ARTICLE: "io" "Input and output"
 { $heading "Other features" }
 { $subsection "network-streams" }
 { $subsection "io.launcher" }
-{ $subsection "io.timeouts" } ;
+{ $subsection "io.timeouts" }
+{ $subsection "checksums" } ;
 
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.vocabs" }

extra/html/elements/elements.factor

@@ -143,7 +143,7 @@ SYMBOL: html
         "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
         "ol" "li" "form" "a" "p" "html" "head" "body" "title"
         "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
-        "script" "div" "span" "select" "option" "style"
+        "script" "div" "span" "select" "option" "style" "input"
     ] [ define-closed-html-word ] each
 
     ! Define some open HTML tags
@@ -161,6 +161,6 @@ SYMBOL: html
         "id" "onclick" "style" "valign" "accesskey"
         "src" "language" "colspan" "onchange" "rel"
         "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
-        "media" "title"
+        "media" "title" "multiple"
     ] [ define-attribute-word ] each
 ] with-compilation-unit

extra/http/http-tests.factor

@@ -1,6 +1,6 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite ;
+assocs io.sockets db db.sqlite continuations ;
 IN: http.tests
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -24,6 +24,12 @@ IN: http.tests
 [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
 [ "/bar" ] [ "/bar" url>path ] unit-test
 
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
@@ -93,7 +99,7 @@ Host: www.sex.com
 
 STRING: read-response-test-1
 HTTP/1.1 404 not found
-Content-Type: text/html
+Content-Type: text/html; charset=UTF8
 
 blah
 ;
@@ -103,8 +109,10 @@ blah
         version: "1.1"
         code: 404
         message: "not found"
-        header: H{ { "content-type" "text/html" } }
+        header: H{ { "content-type" "text/html; charset=UTF8" } }
         cookies: V{ }
+        content-type: "text/html"
+        content-charset: "UTF8"
     }
 ] [
     read-response-test-1 lf>crlf
@@ -114,7 +122,7 @@ blah
 
 STRING: read-response-test-1'
 HTTP/1.1 404 not found
-content-type: text/html
+content-type: text/html; charset=UTF8
 
 
 ;
@@ -140,11 +148,13 @@ accessors namespaces threads ;
 
 : add-quit-action
     <action>
-        [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+        [ stop-server [ "Goodbye" write ] <html-content> ] >>display
     "quit" add-responder ;
 
 : test-db "test.db" temp-file sqlite-db ;
 
+[ test-db drop delete-file ] ignore-errors
+
 test-db [
     init-sessions-table
 ] with-db
@@ -191,7 +201,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> <protected>
+            <action> f <protected>
             <login>
             <sessions>
             "" add-responder

extra/http/http.factor

@@ -119,21 +119,41 @@ IN: http
         header-value>string check-header-string write crlf
     ] assoc-each crlf ;
 
+: add-query-param ( value key assoc -- )
+    [
+        at [
+            {
+                { [ dup string? ] [ swap 2array ] }
+                { [ dup array? ] [ swap suffix ] }
+                { [ dup not ] [ drop ] }
+            } cond
+        ] when*
+    ] 2keep set-at ;
+
 : query>assoc ( query -- assoc )
     dup [
-        "&" split [
+        "&" split H{ } clone [
-            "=" split1 [ dup [ url-decode ] when ] bi@
+            [
-        ] H{ } map>assoc
+                >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+                add-query-param
+            ] curry each
+        ] keep
     ] when ;
 
 : assoc>query ( hash -- str )
     [
-        [ url-encode ]
+        {
-        [ dup number? [ number>string ] when url-encode ]
+            { [ dup number? ] [ number>string ] }
-        bi*
+            { [ dup string? ] [ 1array ] }
-        "=" swap 3append
+            { [ dup sequence? ] [ ] }
-    ] { } assoc>map
+        } cond
-    "&" join ;
+    ] assoc-map
+    [
+        [
+            >r url-encode r>
+            [ url-encode "=" swap 3append , ] with each
+        ] assoc-each
+    ] { } make "&" join ;
 
 TUPLE: cookie name value path domain expires max-age http-only ;
 
@@ -291,6 +311,12 @@ SYMBOL: max-post-request
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
+: parse-content-type-attributes ( string -- attributes )
+    " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
+
+: parse-content-type ( content-type -- type encoding )
+    ";" split1 parse-content-type-attributes "charset" swap at ;
+
 : read-request ( -- request )
     <request>
     read-method
@@ -377,6 +403,8 @@ code
 message
 header
 cookies
+content-type
+content-charset
 body ;
 
 : <response>
@@ -403,7 +431,10 @@ body ;
 
 : read-response-header
     read-header >>header
-    dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
+    extract-cookies
+    dup "content-type" header [
+        parse-content-type [ >>content-type ] [ >>content-charset ] bi*
+    ] when* ;
 
 : read-response ( -- response )
     <response>
@@ -422,10 +453,15 @@ body ;
 : write-response-message ( response -- response )
     dup message>> write crlf ;
 
+: unparse-content-type ( request -- content-type )
+    [ content-type>> "application/octet-stream" or ]
+    [ content-charset>> ] bi
+    [ "; charset=" swap 3append ] when* ;
+
 : write-response-header ( response -- response )
     dup header>> clone
-    over cookies>> f like
+    over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
-    [ unparse-cookies "set-cookie" pick set-at ] when*
+    over unparse-content-type "content-type" pick set-at
     write-header ;
 
 GENERIC: write-response-body* ( body -- )
@@ -453,9 +489,6 @@ M: response write-full-response ( request response -- )
     dup write-response
     swap method>> "HEAD" = [ write-response-body ] unless ;
 
-: set-content-type ( request/response content-type -- request/response )
-    "content-type" set-header ;
-
 : get-cookie ( request/response name -- cookie/f )
     >r cookies>> r> '[ , _ name>> = ] find nip ;
 

extra/http/server/auth/admin/admin.factor

@@ -1,25 +1,36 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators
+USING: kernel sequences accessors namespaces combinators words
-locals db.tuples
+assocs locals db.tuples arrays splitting strings qualified
+
 http.server.templating.chloe
 http.server.boilerplate
 http.server.auth.providers
 http.server.auth.providers.db
 http.server.auth.login
+http.server.auth
 http.server.forms
 http.server.components.inspector
-http.server.components
 http.server.validators
 http.server.sessions
 http.server.actions
 http.server.crud
 http.server ;
+EXCLUDE: http.server.components => string? number? ;
 IN: http.server.auth.admin
 
 : admin-template ( name -- template )
     "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
 
+: words>strings ( seq -- seq' )
+    [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+
+: strings>words ( seq -- seq' )
+    [ ":" split1 swap lookup ] map ;
+
+: <capabilities> ( id -- component )
+    capabilities get words>strings <menu> ;
+
 : <new-user-form> ( -- form )
     "user" <form>
         "new-user" admin-template >>edit-template
@@ -27,7 +38,8 @@ IN: http.server.auth.admin
         "realname" <string> add-field
         "new-password" <password> t >>required add-field
         "verify-password" <password> t >>required add-field
-        "email" <email> add-field ;
+        "email" <email> add-field
+        "capabilities" <capabilities> add-field ;
 
 : <edit-user-form> ( -- form )
     "user" <form>
@@ -38,7 +50,8 @@ IN: http.server.auth.admin
         "new-password" <password> add-field
         "verify-password" <password> add-field
         "email" <email> add-field
-        "profile" <inspector> add-field ;
+        "profile" <inspector> add-field
+        "capabilities" <capabilities> add-field ;
 
 : <user-list-form> ( -- form )
     "user-list" <form>
@@ -77,7 +90,7 @@ IN: http.server.auth.admin
             "username" value <user>
                 "realname" value >>realname
                 "email" value >>email
-                "new-password" value >>password
+                "new-password" value >>encoded-password
                 H{ } clone >>profile
 
             insert-tuple
@@ -99,6 +112,7 @@ IN: http.server.auth.admin
                 [ realname>> "realname" set-value ]
                 [ email>> "email" set-value ]
                 [ profile>> "profile" set-value ]
+                [ capabilities>> words>strings "capabilities" set-value ]
             } cleave
         ] >>init
 
@@ -116,9 +130,14 @@ IN: http.server.auth.admin
             { "new-password" "verify-password" }
             [ value empty? ] all? [
                 same-password-twice
-                "new-password" value >>password
+                "new-password" value >>encoded-password
             ] unless
 
+            "capabilities" value {
+                { [ dup string? ] [ 1array ] }
+                { [ dup array? ] [ ] }
+            } cond strings>words >>capabilities
+
             update-tuple
 
             next f <standard-redirect>
@@ -139,6 +158,10 @@ IN: http.server.auth.admin
 
 TUPLE: user-admin < dispatcher ;
 
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
 :: <user-admin> ( -- responder )
     [let | ctor [ [ <user> ] ] |
         user-admin new-dispatcher
@@ -148,5 +171,11 @@ TUPLE: user-admin < dispatcher ;
             ctor "$user-admin" <delete-user-action> "delete" add-responder
         <boilerplate>
             "admin" admin-template >>template
-        <protected>
+        { can-administer-users? } <protected>
     ] ;
+
+: make-admin ( username -- )
+    <user>
+    select-tuple
+    [ can-administer-users? suffix ] change-capabilities
+    update-tuple ;

extra/http/server/auth/admin/admin.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:style include="resource:extra/http/server/auth/admin/admin.css" />
+	<t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
 
 	<div class="navbar">
 		  <t:a t:href="$user-admin">List Users</t:a>