Permalink
Browse files

Fix regression with: bad interaction between predicate classes and tu…

…ple inheritance, reported by Bruno Deferrari
  • Loading branch information...
1 parent 9de8b5d commit 3e9ca25344f3eed2234aa6f48bc7b608e78c42ac Slava Pestov committed May 13, 2009
Showing with 40 additions and 11 deletions.
  1. +16 −3 core/classes/predicate/predicate-tests.factor
  2. +24 −8 core/generic/single/single.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
@@ -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,14 +228,18 @@ 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
prune-redundant-predicates
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 ]

0 comments on commit 3e9ca25

Please sign in to comment.