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 classes.tuple classes.tuple.private combinators definitions
6 kernel kernel.private math math.private quotations sequences
7 slots.private sorting splitting words ;
10 PREDICATE: union-class < class
11 "metaclass" word-prop union-class eq? ;
15 GENERIC: union-of-builtins? ( class -- ? )
17 M: builtin-class union-of-builtins? drop t ;
19 M: union-class union-of-builtins?
20 class-members [ union-of-builtins? ] all? ;
22 M: class union-of-builtins?
25 : empty-union-predicate-quot ( class -- quot )
28 : flatten-builtins ( class/builtin-classes -- seq )
30 [ flatten-class ] map concat
35 : builtin-union-mask ( builtin-classes -- n )
36 0 [ class>type 2^ bitor ] reduce ;
38 : builtin-union-predicate-quot ( class/builtin-classes -- quot )
39 flatten-builtins dup length 1 = [
40 first class>type [ eq? ] curry [ tag ] prepose
42 builtin-union-mask 1quotation
43 [ tag 1 swap fixnum-shift-fast ]
44 [ fixnum-bitand 0 eq? not ]
48 : predicate-quot ( predicates -- quot )
50 [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
52 ! this replicates logic in classes.tuple, keep in sync
53 : tuple-union-predicate-quot/1 ( tuple-classes -- quot )
54 [ [ eq? ] curry ] map predicate-quot
57 : tuple-union-predicate-quot/n ( echelon tuple-classes -- quot )
58 [ layout-class-offset ] dip
59 [ [ eq? ] curry ] map predicate-quot
60 over [ slot ] curry prepose [ drop f ] [ if ] 2curry
61 swap [ fixnum>= ] curry [ dup 1 slot ] prepose prepose ;
63 : tuple-union-predicate-quot ( tuple-classes -- quot )
64 [ echelon-of 1 = ] partition
65 [ [ f ] [ tuple-union-predicate-quot/1 ] if-empty ] dip
66 [ echelon-of ] collect-by sort-keys
67 [ tuple-union-predicate-quot/n ] { } assoc>map
68 swap [ suffix ] when* predicate-quot
69 [ layout-of ] prepose [ drop f ] [ if ] 2curry
70 [ dup tuple? ] prepose ;
72 : full-union-predicate-quot ( class -- quot )
74 [ union-of-builtins? ] partition
75 [ [ f ] [ builtin-union-predicate-quot ] if-empty ] dip
76 [ [ tuple-class? ] [ tuple-layout ] bi and ] partition
77 [ [ f ] [ tuple-union-predicate-quot ] if-empty ] dip
83 : union-predicate-quot ( class -- quot )
85 { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
86 { [ dup union-of-builtins? ] [ builtin-union-predicate-quot ] }
87 [ full-union-predicate-quot ]
90 : define-union-predicate ( class -- )
91 dup union-predicate-quot define-predicate ;
93 M: union-class update-class define-union-predicate ;
95 ERROR: cannot-reference-self class members ;
97 : check-self-reference ( class members -- class members )
98 2dup all-contained-classes member-eq? [ cannot-reference-self ] when ;
100 : (define-union-class) ( class members -- )
101 check-self-reference f swap f union-class make-class-props (define-class) ;
105 : define-union-class ( class members -- )
106 [ (define-union-class) ]
107 [ drop changed-conditionally ]
108 [ drop update-classes ]
111 M: union-class rank-class drop 7 ;
113 M: union-class instance?
114 "members" word-prop [ instance? ] with any? ;
116 M: anonymous-union instance?
117 members>> [ instance? ] with any? ;
119 M: anonymous-union class-name
120 members>> [ class-name ] map unwords ;
122 M: union-class normalize-class
123 class-members <anonymous-union> normalize-class ;
125 M: union-class (flatten-class)
126 class-members <anonymous-union> (flatten-class) ;