1 ! Copyright (C) 2004, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes classes.algebra
4 classes.algebra.private classes.builtin classes.private
5 combinators definitions kernel kernel.private math math.private
6 quotations sequences sets words ;
9 PREDICATE: union-class < class
10 "metaclass" word-prop union-class eq? ;
14 GENERIC: union-of-builtins? ( class -- ? )
16 M: builtin-class union-of-builtins? drop t ;
18 M: union-class union-of-builtins?
19 class-members [ union-of-builtins? ] all? ;
21 M: class union-of-builtins?
24 : fast-union-mask ( class -- n )
25 [ 0 ] dip flatten-class
26 [ drop class>type 2^ bitor ] assoc-each ;
28 : empty-union-predicate-quot ( class -- quot )
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 ]
37 : slow-union-predicate-quot ( class -- quot )
38 class-members [ predicate-def ] map unclip swap
39 [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
41 : union-predicate-quot ( class -- quot )
43 { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
44 { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
45 [ slow-union-predicate-quot ]
48 : define-union-predicate ( class -- )
49 dup union-predicate-quot define-predicate ;
51 M: union-class update-class define-union-predicate ;
53 : (define-union-class) ( class members -- )
54 f swap f union-class make-class-props (define-class) ;
56 ERROR: cannot-reference-self class members ;
58 GENERIC: classes-contained-by ( obj -- members )
60 M: union-class classes-contained-by ( union -- members )
61 "members" word-prop [ f ] when-empty ;
63 M: object classes-contained-by
64 "members" word-prop [ f ] when-empty ;
66 : check-self-reference ( class members -- class members )
68 dup dup [ classes-contained-by ] map concat sift append
69 2dup set= [ 2drop f ] [ nip ] if
71 member-eq? [ throw-cannot-reference-self ] when ;
75 : define-union-class ( class members -- )
76 [ check-self-reference (define-union-class) ]
77 [ drop changed-conditionally ]
78 [ drop update-classes ]
81 M: union-class rank-class drop 7 ;
83 M: union-class instance?
84 "members" word-prop [ instance? ] with any? ;
86 M: anonymous-union instance?
87 members>> [ instance? ] with any? ;
89 M: anonymous-union class-name
90 members>> [ class-name ] map " " join ;
92 M: union-class normalize-class
93 class-members <anonymous-union> normalize-class ;
95 M: union-class (flatten-class)
96 class-members <anonymous-union> (flatten-class) ;