classes.union: faster builtin-class check, for example sequence?.
							parent
							
								
									17aa52f51c
								
							
						
					
					
						commit
						12dc9e7ab7
					
				| 
						 | 
				
			
			@ -3,7 +3,7 @@
 | 
			
		|||
USING: accessors assocs classes classes.algebra
 | 
			
		||||
classes.algebra.private classes.builtin classes.private
 | 
			
		||||
combinators definitions kernel kernel.private math math.private
 | 
			
		||||
quotations sequences sets words ;
 | 
			
		||||
quotations sequences sets sorting words ;
 | 
			
		||||
IN: classes.union
 | 
			
		||||
 | 
			
		||||
PREDICATE: union-class < class
 | 
			
		||||
| 
						 | 
				
			
			@ -21,20 +21,28 @@ M: union-class union-of-builtins?
 | 
			
		|||
M: class union-of-builtins?
 | 
			
		||||
    drop f ;
 | 
			
		||||
 | 
			
		||||
: fast-union-mask ( class -- n )
 | 
			
		||||
    flatten-class 0 [ class>type 2^ bitor ] reduce ;
 | 
			
		||||
 | 
			
		||||
: empty-union-predicate-quot ( class -- quot )
 | 
			
		||||
    drop [ drop f ] ;
 | 
			
		||||
 | 
			
		||||
: fast-union-predicate-quot ( class -- quot )
 | 
			
		||||
: fast-union-mask ( class/builtin-classes -- n )
 | 
			
		||||
    dup sequence? [ flatten-class ] unless
 | 
			
		||||
    0 [ class>type 2^ bitor ] reduce ;
 | 
			
		||||
 | 
			
		||||
: fast-union-predicate-quot ( class/builtin-classes -- quot )
 | 
			
		||||
    fast-union-mask 1quotation
 | 
			
		||||
    [ tag 1 swap fixnum-shift-fast ]
 | 
			
		||||
    [ fixnum-bitand 0 eq? not ]
 | 
			
		||||
    surround ;
 | 
			
		||||
 | 
			
		||||
: slow-union-predicate-quot ( class -- quot )
 | 
			
		||||
    class-members [ predicate-def ] map unclip swap
 | 
			
		||||
    class-members
 | 
			
		||||
    dup [ builtin-class? ] count 1 > [
 | 
			
		||||
        [ builtin-class? ] partition
 | 
			
		||||
        [ predicate-def ] map swap
 | 
			
		||||
        [ fast-union-predicate-quot suffix ] unless-empty
 | 
			
		||||
    ] [
 | 
			
		||||
        [ predicate-def ] map
 | 
			
		||||
    ] if unclip swap
 | 
			
		||||
    [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
 | 
			
		||||
 | 
			
		||||
: union-predicate-quot ( class -- quot )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue