diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 7b8036ff77..9bbb722258 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -1,9 +1,10 @@ -USING: alien arrays definitions generic assocs hashtables io -kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes +USING: accessors alien arrays definitions generic assocs +hashtables io kernel math namespaces parser prettyprint +sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate -classes.algebra source-files compiler.units kernel.private -sorting vocabs io.streams.string eval see ; +classes.algebra classes.union.private source-files +compiler.units kernel.private sorting vocabs io.streams.string +eval see math.private ; IN: classes.union.tests ! DEFER: bah @@ -49,6 +50,8 @@ UNION: empty-union-2 ; M: empty-union-2 empty-union-test ; +[ [ drop f ] ] [ \ empty-union-1? def>> ] unit-test + ! Redefining a class didn't update containing unions UNION: redefine-bug-1 fixnum ; @@ -90,3 +93,17 @@ M: a-union test-generic ; [ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test [ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test + +! Fast union predicates + +[ t ] [ integer union-of-builtins? ] unit-test + +[ t ] [ \ integer? def>> \ fixnum-bitand swap member? ] unit-test + +[ ] [ "IN: classes.union.tests USE: math UNION: fast-union-1 fixnum ; UNION: fast-union-2 fast-union-1 bignum ;" eval( -- ) ] unit-test + +[ t ] [ "fast-union-2?" "classes.union.tests" lookup def>> \ fixnum-bitand swap member? ] unit-test + +[ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test + +[ f ] [ "fast-union-2?" "classes.union.tests" lookup def>> \ fixnum-bitand swap member? ] unit-test diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index d6abe5201f..bee1e4c271 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2004, 2010 Slava Pestov. +! Copyright (C) 2004, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes classes.private classes.algebra classes.algebra.private -namespaces arrays math quotations definitions ; +classes.builtin kernel.private math.private namespaces arrays +math quotations definitions ; IN: classes.union PREDICATE: union-class < class @@ -10,18 +11,42 @@ PREDICATE: union-class < class assoc alist>quot - ] if-empty ; +GENERIC: union-of-builtins? ( class -- ? ) + +M: builtin-class union-of-builtins? drop t ; + +M: union-class union-of-builtins? + members [ union-of-builtins? ] all? ; + +M: class union-of-builtins? + drop f ; + +: fast-union-mask ( class -- n ) + [ 0 ] dip flatten-class + [ drop class>type 2^ bitor ] assoc-each ; + +: empty-union-predicate-quot ( class -- quot ) + drop [ drop f ] ; + +: fast-union-predicate-quot ( class -- quot ) + fast-union-mask 1quotation + [ tag 1 swap fixnum-shift-fast ] + [ fixnum-bitand 0 eq? not ] + surround ; + +: slow-union-predicate-quot ( class -- quot ) + members [ "predicate" word-prop ] map unclip swap + [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ; + +: union-predicate-quot ( class -- quot ) + { + { [ dup members empty? ] [ empty-union-predicate-quot ] } + { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] } + [ slow-union-predicate-quot ] + } cond ; : define-union-predicate ( class -- ) - dup members union-predicate-quot define-predicate ; + dup union-predicate-quot define-predicate ; M: union-class update-class define-union-predicate ;