Rename specific-method to method-for-class, rename (effective-method) to method-for...

diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index 45ea841a739d47621fd2adf0c01cfca79fbb1b8f..18679ce77bb5731ec9171d8db56ec2f9b71fedb7 100644 (file)
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * )
 
 [ t ] [ \ <tuple>-regression optimized? ] unit-test
 
-GENERIC: foozul ( a -- b )
-M: reversed foozul ;
-M: integer foozul ;
-M: slice foozul ;
-
-[ t ] [
-    reversed \ foozul specific-method
-    reversed \ foozul method
-    eq?
-] unit-test
-
 ! regression
 : constant-fold-2 ( -- value ) f ; foldable
 : constant-fold-3 ( -- value ) 4 ; foldable

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 0b50632e4e0c0bdef5277a2302b3a6dd1f0622aa..367427c7168aa0659c07366630e79062af3e8de0 100755 (executable)
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ;
         2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
             [ swap nth value-info class>> dup ] dip
-            specific-method
+            method-for-class
         ] if
     ] if ;
 

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index e08a21d4b99fd721d7ab21f252e2d2643bdf93b0..8aa6a821d8eba5ada8e1cc6004d1c6a3f9cd8459 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms
     ! If first input has a known type and second input is an
     ! object, we convert this to [ swap equal? ].
     in-d>> first2 value-info class>> object class= [
-        value-info class>> \ equal? specific-method
+        value-info class>> \ equal? method-for-class
         [ swap equal? ] f ?
     ] [ drop f ] if
 ] "custom-inlining" set-word-prop

diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index 7c66c911de7d93ee716159132f75b0b426fa0631..e72d77ee1f6d89a4ad1103e1f58599deca936ba2 100644 (file)
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/basis/math/partial-dispatch/partial-dispatch.factor
@@ -147,7 +147,7 @@ SYMBOL: fast-math-ops
 : math-both-known? ( word left right -- ? )
     3dup math-op
     [ 2drop 2drop t ]
-    [ drop math-class-max swap specific-method >boolean ] if ;
+    [ drop math-class-max swap method-for-class >boolean ] if ;
 
 : (derived-ops) ( word assoc -- words )
     swap '[ swap first _ eq? nip ] assoc-filter ;

diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor
index cbf6acdeed3123d63b82afe9993f31bfff2c418b..2e14af27f3e6fbb65ed8ede593e5b65f12d90c7f 100644 (file)
--- a/core/classes/algebra/algebra-docs.factor
+++ b/core/classes/algebra/algebra-docs.factor
@@ -10,7 +10,6 @@ ARTICLE: "class-operations" "Class operations"
 { $subsection class-and }\r
 { $subsection class-or }\r
 { $subsection classes-intersect? }\r
-{ $subsection min-class }\r
 "Low-level implementation detail:"\r
 { $subsection flatten-class }\r
 { $subsection flatten-builtin-class }\r
@@ -37,6 +36,7 @@ $nl
 "Operations:"\r
 { $subsection class< }\r
 { $subsection sort-classes }\r
+{ $subsection smallest-class }\r
 "Metaclass order:"\r
 { $subsection rank-class } ;\r
 \r
@@ -73,6 +73,6 @@ HELP: classes-intersect?
 { $values { "first" class } { "second" class } { "?" "a boolean" } }\r
 { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;\r
 \r
-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
+HELP: smallest-class\r
+{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }\r
+{ $description "Outputs a minimum class from the given sequence." } ;\r

diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index d111d1daa213071032ab00efa4f8f4c6d2173017..855a15b66f3b0bba66ff63db05720b2cc4e1bcbc 100644 (file)
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -4,7 +4,7 @@ tools.test words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate\r
 vectors source-files compiler.units growable random\r
 stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors ;\r
+classes.tuple accessors generic.private ;\r
 IN: classes.algebra.tests\r
 \r
 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
@@ -150,6 +150,12 @@ UNION: z1 b1 c1 ;
 ] unit-test\r
 \r
 ! Test method inlining\r
+[ real ] [ { real sequence } smallest-class ] unit-test\r
+[ real ] [ { sequence real } smallest-class ] unit-test\r
+\r
+: min-class ( class classes -- class/f )\r
+    interesting-classes smallest-class ;\r
+\r
 [ f ] [ fixnum { } min-class ] unit-test\r
 \r
 [ string ] [\r

diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index df4f8f2563033899a221203021061625a98c4930..2d67403f9423cbcfd83a9a7e8e794191066c2cb2 100755 (executable)
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -214,10 +214,10 @@ ERROR: topological-sort-failed ;
     [ dup largest-class [ over delete-nth ] dip ]\r
     produce nip ;\r
 \r
-: min-class ( class seq -- class/f )\r
-    over [ classes-intersect? ] curry filter\r
-    [ drop f ] [\r
-        [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
+: smallest-class ( classes -- class/f )\r
+    [ f ] [\r
+        natural-sort <reversed>\r
+        [ ] [ [ class<= ] most ] map-reduce\r
     ] if-empty ;\r
 \r
 GENERIC: (flatten-class) ( class -- )\r

diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index a63cab1c5c230c387b99add5b23e2aa14d20f3bf..e2acbb8fe67b9d6752ad82960f2314eaa3aae776 100755 (executable)
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -186,3 +186,20 @@ GENERIC: move-method-generic ( a -- b )
 [ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
 
 [ { string } ] [ \ move-method-generic order ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ t ] [
+    reversed \ foozul method-for-class
+    reversed \ foozul method
+    eq?
+] unit-test
+
+[ t ] [
+    fixnum \ <=> method-for-class
+    real \ <=> method
+    eq?
+] unit-test
\ No newline at end of file

diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 4b398f6532a9ccb0eb31fcbd8bcad0c2a63fe98e..fcb7a53731269d988dd7b2b3c4f49f712ad0974d 100644 (file)
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -24,20 +24,42 @@ M: generic definition drop f ;
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
+<PRIVATE
+
+: interesting-class? ( class1 class2 -- ? )
+    {
+        ! Case 1: no intersection. Discard and keep going
+        { [ 2dup classes-intersect? not ] [ 2drop t ] }
+        ! Case 2: class1 contained in class2. Add to
+        ! interesting set and keep going.
+        { [ 2dup class<= ] [ nip , t ] }
+        ! Case 3: class1 and class2 are incomparable. Give up
+        [ 2drop f ]
+    } cond ;
+
+: interesting-classes ( class classes -- interesting/f )
+    [ [ interesting-class? ] with all? ] { } make and ;
+
+PRIVATE>
+
+: method-classes ( generic -- classes )
+    "methods" word-prop keys ;
+
 : order ( generic -- seq )
-    "methods" word-prop keys sort-classes ;
+    method-classes sort-classes ;
+
+: nearest-class ( class generic -- class/f )
+    method-classes interesting-classes smallest-class ;
 
-: specific-method ( class generic -- method/f )
-    [ nip ] [ order min-class ] 2bi
-    dup [ swap method ] [ 2drop f ] if ;
+: method-for-class ( class generic -- method/f )
+    [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
 
 GENERIC: effective-method ( generic -- method )
 
 \ effective-method t "no-compile" set-word-prop
 
 : next-method-class ( class generic -- class/f )
-    order [ class<= ] with filter reverse dup length 1 =
-    [ drop f ] [ second ] if ;
+    method-classes [ class< ] with filter smallest-class ;
 
 : next-method ( class generic -- method/f )
     [ next-method-class ] keep method ;

diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor
index 5edbc54bd8b7dd96751c9520a1d6083d26ed705b..5359f473ac5e52beb3420320e925521eee1e246e 100644 (file)
--- a/core/generic/hook/hook.factor
+++ b/core/generic/hook/hook.factor
@@ -23,4 +23,4 @@ M: hook-combination mega-cache-quot
 M: hook-generic definer drop \ HOOK: f ;
 
 M: hook-generic effective-method
-    [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
+    [ "combination" word-prop var>> get ] keep method-for-object ;
\ No newline at end of file

diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index e0e8b91a2cea209cc390f2481a9ce832e37f76f0..297684014bb9a281297600d034b6092440e4db58 100644 (file)
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -50,7 +50,7 @@ ERROR: no-math-method left right generic ;
 
 <PRIVATE
 
-: applicable-method ( generic class -- quot )
+: (math-method) ( generic class -- quot )
     over method
     [ 1quotation ]
     [ default-math-method ] ?if ;
@@ -58,13 +58,13 @@ ERROR: no-math-method left right generic ;
 PRIVATE>
 
 : object-method ( generic -- quot )
-    object bootstrap-word applicable-method ;
+    object bootstrap-word (math-method) ;
 
 : math-method ( word class1 class2 -- quot )
     2dup and [
         [ 2array [ declare ] curry nip ]
         [ math-upgrade nip ]
-        [ math-class-max over order min-class applicable-method ]
+        [ math-class-max over nearest-class (math-method) ]
         3tri 3append
     ] [
         2drop object-method

diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor
index 8a53368062d285979c9505670b0765a797287654..9e773fe700c3eae88017b082e1e9110fb08329c0 100644 (file)
--- a/core/generic/single/single.factor
+++ b/core/generic/single/single.factor
@@ -42,8 +42,8 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
         ] [ 3drop f ] if
     ] with-combination ;
 
-: (effective-method) ( obj word -- method )
-    [ [ order [ instance? ] with find-last nip ] keep method ]
+: method-for-object ( obj word -- method )
+    [ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
     [ "default-method" word-prop ]
     bi or ;
 

diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 0d1220beac84cddeb5a90dfe03bef2e9f9cf53fe..35d299145d7d03aa0bd5ce7e3df18acca5bf4422 100644 (file)
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -40,7 +40,7 @@ M: standard-combination dispatch# #>> ;
 
 M: standard-generic effective-method
     [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
-    (effective-method) ;
+    method-for-object ;
 
 : inline-cache-quot ( word methods miss-word -- quot )
     [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;