-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
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 ;
[ ] [ [ \ 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
-! 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
<PRIVATE
-: union-predicate-quot ( members -- quot )
- [
- [ drop f ]
- ] [
- unclip "predicate" word-prop swap [
- "predicate" word-prop [ dup ] prepend
- [ drop t ]
- ] { } map>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 ;