Class linearization

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 6170eddf521d7fd85fa4a3f5e42d7fe892e02961..68be9c9b06fa83a94af72468069d1e61b54b8683 100755 (executable)
--- a/core/assocs/assocs-docs.factor
+++ b/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"

diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 2f354bfee537d2f66009ddd24ae26d24fb1ecfff..cb73dc387efbbbafef6f199b39792b2498c8ea35 100755 (executable)
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -404,8 +404,8 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<-cache class-not-cache
-            classes-intersect-cache class-and-cache
+            update-map class<=-cache class<=>-cache
+            class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc

diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 8e4108866ffa4fd402f9e117f07160e995b3a22f..3247832d52566b769ba943596bbb4d06fb0578fa 100755 (executable)
--- a/core/bootstrap/stage2.factor
+++ b/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
 

diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor
index 87c72048f495ae70033b006dd26c0a73d443e8f3..3903da1ebcef94d5e5b938165319e36d1e4f9232 100755 (executable)
--- a/core/classes/algebra/algebra-docs.factor
+++ b/core/classes/algebra/algebra-docs.factor
@@ -1,14 +1,14 @@
-USING: help.markup help.syntax kernel classes ;\r
+USING: help.markup help.syntax kernel classes words\r
+checksums checksums.crc32 sequences math ;\r
 IN: classes.algebra\r
 \r
 ARTICLE: "class-operations" "Class operations"\r
 "Set-theoretic operations on classes:"\r
 { $subsection class< }\r
+{ $subsection class<= }\r
 { $subsection class-and }\r
 { $subsection class-or }\r
 { $subsection classes-intersect? }\r
-"Topological sort:"\r
-{ $subsection sort-classes }\r
 { $subsection min-class }\r
 "Low-level implementation detail:"\r
 { $subsection class-types }\r
@@ -17,6 +17,40 @@ ARTICLE: "class-operations" "Class operations"
 { $subsection class-types }\r
 { $subsection class-tags } ;\r
 \r
+ARTICLE: "class-linearization" "Class linearization"\r
+"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:"\r
+{ $list\r
+    "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."\r
+    { "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." }\r
+}\r
+"These difficulties are resolved by imposing a linear order on classes, computed as follows for two classes A and B:"\r
+{ $list\r
+    "If A and B are the same class (not just equal as sets), then comparison stops."\r
+    "If A is a proper subset of B, or B is a proper subset of A, then comparison stops."\r
+    { "Next, the metaclasses of A and B are compared, with intrinsic meta-class order, from most-specific to least-specific:"\r
+        { $list\r
+            "Built-in classes and tuple classes"\r
+            "Predicate classes"\r
+            "Union classes"\r
+            "Mixin classes"\r
+        }\r
+    "If this yields an unambiguous answer, comparison stops."\r
+    }\r
+    "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."\r
+    "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."\r
+}\r
+"Some examples:"\r
+{ $list\r
+    { { $link integer } " precedes " { $link number } " because it is a strict subset" }\r
+    { { $link number } " precedes " { $link sequence } " because the " { $vocab-link "math" } " vocabulary precedes the " { $vocab-link "sequences" } " vocabulary" }\r
+    { { $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" }\r
+}\r
+"Operations:"\r
+{ $subsection class<=> }\r
+{ $subsection sort-classes }\r
+"Metaclass order:"\r
+{ $subsection rank-class } ;\r
+\r
 HELP: flatten-builtin-class\r
 { $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
 { $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;\r
@@ -29,14 +63,16 @@ HELP: class-types
 { $values { "class" class } { "seq" "an increasing sequence of integers" } }\r
 { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;\r
 \r
-HELP: class<\r
+HELP: class<=\r
 { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }\r
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }\r
 { $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" } "." } ;\r
 \r
 HELP: sort-classes\r
 { $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }\r
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
+\r
+{ sort-classes class<=> } related-words\r
 \r
 HELP: class-or\r
 { $values { "first" class } { "second" class } { "class" class } }\r
@@ -53,3 +89,7 @@ HELP: classes-intersect?
 HELP: min-class\r
 { $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
 { $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 } "." } ;\r
+\r
+HELP: class<=>\r
+{ $values { "first" class } { "second" class } { "n" symbol } }\r
+{ $description "Compares two classes with the class linearization order." } ;\r

diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index dba97c16f5b97d82e4e7d377564c9ab8b30b309f..7387b8ae3a6cd06ffc0b704b0ece9a791a0ae509 100755 (executable)
--- a/core/classes/algebra/algebra-tests.factor
+++ b/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\r
 classes.private classes.union classes.mixin classes.predicate\r
 vectors definitions source-files compiler.units growable\r
-random inference effects kernel.private sbufs ;\r
+random inference effects kernel.private sbufs math.order ;\r
 \r
-: class= [ class< ] 2keep swap class< and ;\r
+: class= [ class<= ] [ swap class<= ] 2bi and ;\r
 \r
 : class-and* >r class-and r> class= ;\r
 \r
@@ -38,43 +38,43 @@ UNION: both first-one union-class ;
 \r
 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
 \r
-[ t ] [ \ fixnum \ integer class< ] unit-test\r
-[ t ] [ \ fixnum \ fixnum class< ] unit-test\r
-[ f ] [ \ integer \ fixnum class< ] unit-test\r
-[ t ] [ \ integer \ object class< ] unit-test\r
-[ f ] [ \ integer \ null class< ] unit-test\r
-[ t ] [ \ null \ object class< ] unit-test\r
+[ t ] [ \ fixnum \ integer class<= ] unit-test\r
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
+[ f ] [ \ integer \ fixnum class<= ] unit-test\r
+[ t ] [ \ integer \ object class<= ] unit-test\r
+[ f ] [ \ integer \ null class<= ] unit-test\r
+[ t ] [ \ null \ object class<= ] unit-test\r
 \r
-[ t ] [ \ generic \ word class< ] unit-test\r
-[ f ] [ \ word \ generic class< ] unit-test\r
+[ t ] [ \ generic \ word class<= ] unit-test\r
+[ f ] [ \ word \ generic class<= ] unit-test\r
 \r
-[ f ] [ \ reversed \ slice class< ] unit-test\r
-[ f ] [ \ slice \ reversed class< ] unit-test\r
+[ f ] [ \ reversed \ slice class<= ] unit-test\r
+[ f ] [ \ slice \ reversed class<= ] unit-test\r
 \r
 PREDICATE: no-docs < word "documentation" word-prop not ;\r
 \r
 UNION: no-docs-union no-docs integer ;\r
 \r
-[ t ] [ no-docs no-docs-union class< ] unit-test\r
-[ f ] [ no-docs-union no-docs class< ] unit-test\r
+[ t ] [ no-docs no-docs-union class<= ] unit-test\r
+[ f ] [ no-docs-union no-docs class<= ] unit-test\r
 \r
 TUPLE: a ;\r
 TUPLE: b ;\r
 UNION: c a b ;\r
 \r
-[ t ] [ \ c \ tuple class< ] unit-test\r
-[ f ] [ \ tuple \ c class< ] unit-test\r
+[ t ] [ \ c \ tuple class<= ] unit-test\r
+[ f ] [ \ tuple \ c class<= ] unit-test\r
 \r
-[ t ] [ \ tuple-class \ class class< ] unit-test\r
-[ f ] [ \ class \ tuple-class class< ] unit-test\r
+[ t ] [ \ tuple-class \ class class<= ] unit-test\r
+[ f ] [ \ class \ tuple-class class<= ] unit-test\r
 \r
 TUPLE: tuple-example ;\r
 \r
-[ t ] [ \ null \ tuple-example class< ] unit-test\r
-[ f ] [ \ object \ tuple-example class< ] unit-test\r
-[ f ] [ \ object \ tuple-example class< ] unit-test\r
-[ t ] [ \ tuple-example \ tuple class< ] unit-test\r
-[ f ] [ \ tuple \ tuple-example class< ] unit-test\r
+[ t ] [ \ null \ tuple-example class<= ] unit-test\r
+[ f ] [ \ object \ tuple-example class<= ] unit-test\r
+[ f ] [ \ object \ tuple-example class<= ] unit-test\r
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
 \r
 TUPLE: a1 ;\r
 TUPLE: b1 ;\r
@@ -84,57 +84,57 @@ UNION: x1 a1 b1 ;
 UNION: y1 a1 c1 ;\r
 UNION: z1 b1 c1 ;\r
 \r
-[ f ] [ z1 x1 y1 class-and class< ] unit-test\r
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
 \r
-[ t ] [ x1 y1 class-and a1 class< ] unit-test\r
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
 \r
 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
 \r
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test\r
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
 \r
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test\r
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
 \r
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
 \r
 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
 \r
 [ t ] [\r
-    growable tuple sequence class-and class<\r
+    growable tuple sequence class-and class<=\r
 ] unit-test\r
 \r
 [ t ] [\r
-    growable assoc class-and tuple class<\r
+    growable assoc class-and tuple class<=\r
 ] unit-test\r
 \r
-[ t ] [ object \ f \ f class-not class-or class< ] unit-test\r
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
 \r
 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
 \r
 [ f ] [ integer integer class-not classes-intersect? ] unit-test\r
 \r
-[ t ] [ array number class-not class< ] unit-test\r
+[ t ] [ array number class-not class<= ] unit-test\r
 \r
-[ f ] [ bignum number class-not class< ] unit-test\r
+[ f ] [ bignum number class-not class<= ] unit-test\r
 \r
 [ vector ] [ vector class-not class-not ] unit-test\r
 \r
-[ t ] [ fixnum fixnum bignum class-or class< ] unit-test\r
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
 \r
-[ f ] [ fixnum class-not integer class-and array class< ] unit-test\r
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
 \r
-[ f ] [ fixnum class-not integer class< ] unit-test\r
+[ f ] [ fixnum class-not integer class<= ] unit-test\r
 \r
-[ f ] [ number class-not array class< ] unit-test\r
+[ f ] [ number class-not array class<= ] unit-test\r
 \r
-[ f ] [ fixnum class-not array class< ] unit-test\r
+[ f ] [ fixnum class-not array class<= ] unit-test\r
 \r
-[ t ] [ number class-not integer class-not class< ] unit-test\r
+[ t ] [ number class-not integer class-not class<= ] unit-test\r
 \r
 [ t ] [ vector array class-not class-and vector class= ] unit-test\r
 \r
 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
 \r
-[ f ] [ fixnum class-not integer class< ] unit-test\r
+[ f ] [ fixnum class-not integer class<= ] unit-test\r
 \r
 [ t ] [ null class-not object class= ] unit-test\r
 \r
@@ -147,7 +147,7 @@ UNION: z1 b1 c1 ;
 [ t ] [\r
     fixnum class-not\r
     fixnum fixnum class-not class-or\r
-    class<\r
+    class<=\r
 ] unit-test\r
 \r
 ! Test method inlining\r
@@ -241,3 +241,14 @@ UNION: z1 b1 c1 ;
         =\r
     ] unit-test\r
 ] times\r
+\r
+SINGLETON: xxx\r
+UNION: yyy xxx ;\r
+\r
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
+\r
+[ { number integer ratio } ] [ { ratio number integer } sort-classes ] unit-test\r
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
+\r
+[ +lt+ ] [ \ real sequence class<=> ] unit-test\r

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

diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index 1c2871b03182751f33b22b7211ba3323f2e96660..8e992b852e942dc1c2bdf5e7d03dfc08955e8063 100644 (file)
--- a/core/classes/builtin/builtin.factor
+++ b/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 ;

diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 5971ffd9fa8b81aca6acdf827b2a19b47150f828..744944c2817b1d6f48aa2fe88eb2272942e3e416 100755 (executable)
--- a/core/classes/classes-docs.factor
+++ b/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"

diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index ae19f38d14f97159b40c274d045c7e6d05291d50..bb9fbd0167a03e4a72a6b5e2201d843f0b55b164 100755 (executable)
--- a/core/classes/classes-tests.factor
+++ b/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
-[ t ] [ union-1 number class< ] unit-test
+[ f ] [ bignum union-1 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
-[ f ] [ union-1 number class< ] unit-test
+[ t ] [ bignum union-1 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 ] [ mx1 integer class< ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
 
 "IN: classes.tests USE: arrays INSTANCE: array mx1" eval
 
-[ t ] [ array mx1 class< ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ t ] [ array mx1 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 ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum 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
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
 
 USE: io.streams.string
 

diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index c998a1b15515b4197c159463f62967cf18e8b778..53840c002725387ee5e99bdf87e3e73d49e002a3 100755 (executable)
--- a/core/classes/classes.factor
+++ b/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 ;

diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index ca2547bacfefa19f9df03e1f4ed0ee8c088d1c5b..6f888ceca167a6b91751ffb1a23f5757f55361a8 100755 (executable)
--- a/core/classes/mixin/mixin.factor
+++ b/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 ;

diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 4729a6dd5ea4396b8770bed2cddcf225f6b9fbee..4e4d1701e49bb0f283319d9556372cbbd873da32 100755 (executable)
--- a/core/classes/predicate/predicate.factor
+++ b/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 ;

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 41776c4eec8433ffb77a8865cba433cac95807d9..0cde687f160a99499f56576fd0c2d4b5c60c46d8 100755 (executable)
--- a/core/classes/tuple/tuple-tests.factor
+++ b/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 computer class< ] unit-test
+[ t ] [ laptop tuple 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 computer class< ] unit-test
+[ t ] [ server tuple 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 ] [ laptop server class< ] unit-test
+[ f ] [ server laptop 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
-[ t ] [ server electronic-device class< ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
+[ t ] [ server 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

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 8bcf023131d7c23a078d9502f0d43b7aba7d9c3d..ee7ff8c6084f26fc6196bfbc7201dd503bb260f5 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/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 ;
 

diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 09f8f88cedaa8810b61ae339544c9e105aa75c36..760844afb9d6166776ad2e8810ec953bdeeb4a13 100755 (executable)
--- a/core/classes/union/union.factor
+++ b/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 ;

diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index e0fd7bd457d3f65dc3a0bb8703744e034d383bda..c5e1ea54a63f562095cde24d5aa881d37b865d35 100755 (executable)
--- a/core/generator/registers/registers.factor
+++ b/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 simple-alien class< ] [ drop %unbox-alien ] }
-        { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
-        { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
-        { [ dup float-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup \ f class<= ] [ drop %unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+        { [ dup bit-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

diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 1024c377a8c18c5c4a47de2f741dcd7c2372ddd1..39293bfec979c4e32ac0d4d195e11bb19134cbe0 100755 (executable)
--- a/core/generic/generic-docs.factor
+++ b/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."
-$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."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
 $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:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"The linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number }" }
+"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"

diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 82bab475b301c87edc5520415cc420517438e88a..d35ba01e52f9a4133f490e25876c07ef10320a62 100755 (executable)
--- a/core/generic/generic.factor
+++ b/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 )

diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 90590fe565568c53ba48fbc54619bcb8e3b548cf..1c1368a6c22991fcacaaeb3e04015af8f36f7178 100755 (executable)
--- a/core/generic/math/math.factor
+++ b/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 ;

diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
index c09f1abfd4963e0ee3491465d60b1a006e800165..20e22fde82dd77bb53ab67eabdccd5ffe7c50074 100644 (file)
--- a/core/generic/standard/engines/engines.factor
+++ b/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<     ] curry assoc-filter ] 2bi ;
+    [ [ nip class<= not ] curry assoc-filter ]
+    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
 
 : convert-methods ( assoc class word -- assoc' )
     over >r >r split-methods dup assoc-empty? [

diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index e4643b2f3dd1f656b534597bb5338565926d470a..b1bfc659df7aeec4e0e70dae58c963cf381a3348 100644 (file)
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/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' )
     {

diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 9d0c55afeb94af316effe3756e346c3d69905ee1..933710aaca396424ab56c9c899e13a7263756205 100755 (executable)
--- a/core/inference/class/class.factor
+++ b/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

diff --git a/core/math/math.factor b/core/math/math.factor
index d5040757d4ea3f60a3d37aab79e341d496ed8f27..0218ded6ff61c3323318d1f8775b56698569ba1b 100755 (executable)
--- a/core/math/math.factor
+++ b/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?

diff --git a/core/math/order/order.factor b/core/math/order/order.factor
index 7cbef68dcc91dfa344f05102416af03e4e47f17c..76fe058ffab757c4c0c183bda9b6c08103d6e939 100644 (file)
--- a/core/math/order/order.factor
+++ b/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 <=> (<=>) ;
-M: integer <=> (<=>) ;
+GENERIC: <=> ( obj1 obj2 -- symbol )
+
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
 
 GENERIC: before? ( obj1 obj2 -- ? )
 GENERIC: after? ( obj1 obj2 -- ? )

diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
index de7aec2bb15841ace59a96a10307164ffa470341..7ab0ffc8067e117ff3dc2e6ec550abf3fbfc948f 100755 (executable)
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -154,9 +154,9 @@ SYMBOL: potential-loops
         node-literal t
     ] [
         node-class {
-            { [ dup null class< ] [ drop f f ] }
-            { [ dup \ f class-not class< ] [ drop t t ] }
-            { [ dup \ f class< ] [ drop f t ] }
+            { [ dup null class<= ] [ drop f f ] }
+            { [ dup \ f class-not class<= ] [ drop t t ] }
+            { [ dup \ f class<= ] [ drop f t ] }
             [ drop f f ]
         } cond
     ] if ;

diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 33c8244b4c0d68bb36eb9bd27e368e3a81e3626d..393264e459e89905926274a9f0fe5d1975f26374 100755 (executable)
--- a/core/optimizer/inlining/inlining.factor
+++ b/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

diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index ab8a1f3edade40a745034710709b85240ba36925..72e64d5b95e22e555ba2583eb80f4815e1e3121e 100755 (executable)
--- a/core/optimizer/math/math.factor
+++ b/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 ]

diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor
index 5beb2555f0412fe52697036a882c41d38a87f28d..51fa254a258e81d9e625148f479381e0fdada8af 100755 (executable)
--- a/core/optimizer/pattern-match/pattern-match.factor
+++ b/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 -- ? )
     {

diff --git a/extra/db/pooling/pooling-tests.factor b/extra/db/pooling/pooling-tests.factor
new file mode 100644 (file)
index 0000000..7b0de65
--- /dev/null
+++ b/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

diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor
new file mode 100644 (file)
index 0000000..8382029
--- /dev/null
+++ b/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 ;

diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor
index 6ad0774e387b8311daaa3e53bfe32b53584ba245..a68c65087ea149e840d8cda31d11c1e7bdc7d840 100644 (file)
--- a/extra/json/writer/writer.factor
+++ b/extra/json/writer/writer.factor
@@ -21,11 +21,6 @@ M: string json-print ( obj -- )
 M: number json-print ( num -- )  
   number>string write ;
 
-! sequence and number overlap, we provide an explicit
-! disambiguation method
-M: integer json-print ( num -- )  
-  number>string write ;
-
 M: sequence json-print ( array -- ) 
   CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
 

diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index d5a698f5f8609c36cb30264fd7680983ad191612..59e8049232b27a78c2336378aa84221c44c2a6b6 100755 (executable)
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -86,12 +86,12 @@ SYMBOL: total
     [
         {
             { [ 2dup eq? ] [ +eq+ ] }
-            { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
-            { [ 2dup class< ] [ +lt+ ] }
-            { [ 2dup swap class< ] [ +gt+ ] }
+            { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+            { [ 2dup class<= ] [ +lt+ ] }
+            { [ 2dup swap class<= ] [ +gt+ ] }
             [ +eq+ ]
         } cond 2nip
-    ] 2map [ zero? not ] find nip +eq+ or ;
+    ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
 
 : sort-methods ( alist -- alist' )
     [ [ first ] bi@ classes< ] topological-sort ;

diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index f95b83467acaa34e704cebc25594cfb944031bb8..1ad9957cc97bd27457c680c88c63aded0e649622 100755 (executable)
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -144,7 +144,8 @@ IN: tools.deploy.shaker
                 classes:class-and-cache
                 classes:class-not-cache
                 classes:class-or-cache
-                classes:class<-cache
+                classes:class<=-cache
+                classes:class<=>-cache
                 classes:classes-intersect-cache
                 classes:update-map
                 command-line:main-vocab-hook