diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index a947b9ddc0..80613f4f2e 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/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 \ No newline at end of file +[ 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 diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8d84b21bf7..747963256d 100644 --- a/core/generic/single/single.factor +++ b/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 ; -: ( methods -- engine ) predicate-engine boa ; +C: predicate-engine : push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* + dupd [ + [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep ] change-at ; @@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine [ 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 ; - : ( -- word ) generic-word get name>> "/predicate-engine" append f 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 ; [ ] 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 ]