more generic fixes

library/generic/complement.factor

@@ -25,7 +25,7 @@ complement [
 : define-complement ( class complement -- )
     2dup "complement" set-word-prop
     dupd complement-predicate "predicate" set-word-prop
-    dup complement-types "types" set-word-prop
+    dup dup complement-types "types" set-word-prop
     complement define-class ;
 
 PREDICATE: word complement metaclass complement = ;

library/generic/generic.factor

@@ -26,21 +26,40 @@ math-internals ;
 : set-vtable ( definition class vtable -- )
     >r types first r> set-nth ;
 
-: 2types ( class class -- seq seq )
-    swap types swap types ;
+: 2types ( class class -- seq seq ) swap types swap types ;
 
-: class< ( cls1 cls2 -- ? )
-    #! Test if class1 is a subclass of class2.
+: (class<) 2types contained? ;
+
+: superclass? ( cls1 cls2 -- ? )
+    #! Is cls1 a superclass of cls2?
     2dup eq? [
         2drop t
     ] [
-        2dup "superclass" word-prop dup [
-            swap class< not 2nip
+        "superclass" word-prop dup [
+            superclass?
         ] [
-            2drop 2types contained?
+            2drop f
         ] ifte
     ] ifte ;
 
+: child-has-super? ( cls1 cls2 -- ? )
+    swap "superclass" word-prop not
+    swap "superclass" word-prop and ;
+
+: both-have-super? ( cls1 cls2 -- ? )
+    swap "superclass" word-prop
+    swap "superclass" word-prop and ;
+
+: custom-class< metaclass "class<" word-prop ;
+
+: class< ( cls1 cls2 -- ? )
+    #! Test if class1 is a subclass of class2.
+    {
+        { [ 2dup eq? ] [ 2drop t ] }
+        { [ dup custom-class< ] [ dup custom-class< call ] }
+        { [ t ] [ (class<) ] }
+    } cond ;
+
 : class-compare ( cls1 cls2 -- -1/0/1 )
     2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] ifte ;
 
@@ -50,6 +69,12 @@ math-internals ;
 : order ( generic -- list )
     "methods" word-prop hash-keys [ class-compare ] sort ;
 
+: min-class ( class seq -- class/f )
+    #! Is this class the smallest class in the sequence?
+    [ dupd class-and null = not ] subset
+    [ class-compare neg ] sort
+    tuck [ class< ] all-with? [ first ] [ drop f ] ifte ;
+
 : add-method ( generic vtable definition class -- )
     #! Add the method entry to the vtable. Unlike define-method,
     #! this is called at vtable build time, and in the sorted
@@ -65,6 +90,8 @@ math-internals ;
 : error-method ( generic -- method )
     [ dup picker% literalize , \ no-method , ] make-list ;
 
+DEFER: delegate
+
 : empty-method ( generic -- method )
     dup "picker" word-prop [ dup ] = [
         [

library/generic/predicate.factor

@@ -27,6 +27,14 @@ predicate [
     ] each 2drop 2drop
 ] "add-method" set-word-prop
 
+predicate [
+    over metaclass over metaclass eq? [
+        >r "superclass" word-prop r> class<
+    ] [
+        drop types empty?
+    ] ifte
+] "class<" set-word-prop
+
 : define-predicate-class ( class predicate definition -- )
     3dup nip "definition" set-word-prop
     pick predicate "metaclass" set-word-prop

library/generic/tuple.factor

@@ -185,6 +185,8 @@ tuple [
     2drop add-tuple-dispatch
 ] "add-method" set-word-prop
 
+tuple [ 2drop f ] "class<" set-word-prop
+
 PREDICATE: word tuple-class metaclass tuple = ;
 
 : is? ( obj pred -- ? | pred: obj -- ? )

library/inference/inline-methods.factor

@@ -6,12 +6,6 @@ vectors words ;
 
 ! Method inlining optimization
 
-: min-class ( class seq -- class/f )
-    #! Is this class the smallest class in the sequence?
-    [ dupd class-and null = not ] subset
-    [ class-compare neg ] sort
-    tuck [ class< ] all-with? [ first ] [ drop f ] ifte ;
-
 GENERIC: dispatching-values ( node word -- seq )
 
 M: object dispatching-values 2drop { } ;

library/test/compiler/optimizer.factor

@@ -10,6 +10,7 @@ USE: math
 USE: kernel
 USE: lists
 USE: sequences
+USE: prettyprint
 
 ! Some dataflow tests
 ! [ 3 ] [ 1 2 3 (subst-value) ] unit-test
@@ -87,7 +88,7 @@ USE: sequences
 ! Test method inlining
 [ string ] [
     \ string
-    [ range repeated integer string mirror array reversed sbuf
+    [ repeated integer string mirror array reversed sbuf
     slice vector diagonal general-list ]
     min-class
 ] unit-test

library/test/generic.factor

@@ -108,6 +108,9 @@ M: very-funny gooey sq ;
 [ f ] [ \ cons \ list class< ] unit-test
 [ f ] [ \ list \ cons class< ] unit-test
 
+[ f ] [ \ mirror \ slice class< ] unit-test
+[ f ] [ \ slice \ mirror class< ] unit-test
+
 DEFER: bah
 FORGET: bah
 UNION: bah fixnum alien ;