/core/classes/union/union.factor

 1! Copyright (C) 2004, 2011 Slava Pestov.
 2! See http://factorcode.org/license.txt for BSD license.
 3USING: accessors assocs classes classes.algebra
 4classes.algebra.private classes.builtin classes.private
 5combinators definitions kernel kernel.private math math.private
 6quotations sequences words ;
 7IN: classes.union
 8
 9PREDICATE: union-class < class
10    "metaclass" word-prop union-class eq? ;
11
12<PRIVATE
13
14GENERIC: union-of-builtins? ( class -- ? )
15
16M: builtin-class union-of-builtins? drop t ;
17
18M: union-class union-of-builtins?
19    members [ union-of-builtins? ] all? ;
20
21M: class union-of-builtins?
22    drop f ;
23
24: fast-union-mask ( class -- n )
25    [ 0 ] dip flatten-class
26    [ drop class>type 2^ bitor ] assoc-each ;
27
28: empty-union-predicate-quot ( class -- quot )
29    drop [ drop f ] ;
30
31: fast-union-predicate-quot ( class -- quot )
32    fast-union-mask 1quotation
33    [ tag 1 swap fixnum-shift-fast ]
34    [ fixnum-bitand 0 eq? not ]
35    surround ;
36
37: slow-union-predicate-quot ( class -- quot )
38    members [ predicate-def ] map unclip swap
39    [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
40
41: union-predicate-quot ( class -- quot )
42    {
43        { [ dup members empty? ] [ empty-union-predicate-quot ] }
44        { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
45        [ slow-union-predicate-quot ]
46    } cond ;
47
48: define-union-predicate ( class -- )
49    dup union-predicate-quot define-predicate ;
50
51M: union-class update-class define-union-predicate ;
52
53: (define-union-class) ( class members -- )
54    f swap f union-class make-class-props (define-class) ;
55
56PRIVATE>
57
58: define-union-class ( class members -- )
59    [ (define-union-class) ]
60    [ drop changed-conditionally ]
61    [ drop update-classes ]
62    2tri ;
63
64M: union-class rank-class drop 7 ;
65
66M: union-class instance?
67    "members" word-prop [ instance? ] with any? ;
68
69M: anonymous-union instance?
70    members>> [ instance? ] with any? ;
71
72M: anonymous-union class-name
73    members>> [ class-name ] map " " join ;
74
75M: union-class normalize-class
76    members <anonymous-union> normalize-class ;
77
78M: union-class (flatten-class)
79    members <anonymous-union> (flatten-class) ;