Fix regression with: bad interaction between predicate classes and tuple inheritance, reported by Bruno Deferrari

core/classes/predicate/predicate-tests.factor

@@ -1,5 +1,6 @@
-USING: math tools.test classes.algebra words kernel sequences assocs ;
-IN: classes.predicate
+USING: math tools.test classes.algebra words kernel sequences assocs
+accessors eval definitions compiler.units generic ;
+IN: classes.predicate.tests
 
 PREDICATE: negative < integer 0 < ;
 PREDICATE: positive < integer 0 > ;
@@ -18,4 +19,16 @@ M: positive abs ;
 
 [ 10 ] [ -10 abs ] unit-test
 [ 10 ] [ 10 abs ] unit-test
-[ 0 ] [ 0 abs ] unit-test
+[ 0 ] [ 0 abs ] unit-test
+
+! Bug report from Bruno Deferrari
+TUPLE: tuple-a slot ;
+TUPLE: tuple-b < tuple-a ;
+
+PREDICATE: tuple-c < tuple-b slot>> ;
+
+GENERIC: ptest ( tuple -- )
+M: tuple-a ptest drop ;
+IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
+
+[ ] [ tuple-b new ptest ] unit-test

core/generic/single/single.factor

@@ -58,13 +58,13 @@ M: single-combination make-default-method
     ] unless ;
 
 ! 1. Flatten methods
-TUPLE: predicate-engine methods ;
+TUPLE: predicate-engine class methods ;
 
-: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+C: <predicate-engine> predicate-engine
 
 : push-method ( method specializer atomic assoc -- )
-    [
-        [ H{ } clone <predicate-engine> ] unless*
+    dupd [
+        [ ] [ H{ } clone <predicate-engine> ] ?if
         [ methods>> set-at ] keep
     ] change-at ;
 
@@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
         [ <enum> swap update ] keep
     ] with-variable ;
 
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+SYMBOL: predicate-engines
+
 : sort-methods ( assoc -- assoc' )
     >alist [ keys sort-classes ] keep extract-keys ;
 
 : quote-methods ( assoc -- assoc' )
     [ 1quotation \ drop prefix ] assoc-map ;
 
+: find-predicate-engine ( classes -- word )
+    predicate-engines get [ at ] curry map-find drop ;
+
+: next-predicate-engine ( engine -- word )
+    class>> superclasses
+    find-predicate-engine
+    default get or ;
+
 : methods-with-default ( engine -- assoc )
-    methods>> clone default get object bootstrap-word pick set-at ;
+    [ methods>> clone ] [ next-predicate-engine ] bi
+    object bootstrap-word pick set-at ;
 
 : keep-going? ( assoc -- ? )
     assumed get swap second first class<= ;
@@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine
 : class-predicates ( assoc -- assoc )
     [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
 
-PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
-
 : <predicate-engine-word> ( -- word )
     generic-word get name>> "/predicate-engine" append f <word>
     dup generic-word get "owner-generic" set-word-prop ;
@@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
     [ <predicate-engine-word> ] dip
     [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
 
-M: predicate-engine compile-engine
+: compile-predicate-engine ( engine -- word )
     methods-with-default
     sort-methods
     quote-methods
@@ -225,6 +236,10 @@ M: predicate-engine compile-engine
     class-predicates
     [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
 
+M: predicate-engine compile-engine
+    [ compile-predicate-engine ] [ class>> ] bi
+    [ drop ] [ predicate-engines get set-at ] 2bi ;
+
 M: word compile-engine ;
 
 M: f compile-engine ;
@@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f )
 
 M: single-combination perform-combination
     [
+        H{ } clone predicate-engines set
         dup generic-word set
         dup build-decision-tree
         [ "decision-tree" set-word-prop ]