]> gitweb.factorcode.org Git - factor.git/blob - core/classes/classes.factor
use ``if*`` instead of ``dup [ ] [ drop ] if``.
[factor.git] / core / classes / classes.factor
1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators definitions kernel
4 make namespaces quotations sequences sets words words.symbol ;
5 FROM: namespaces => set ;
6 IN: classes
7
8 ERROR: bad-inheritance class superclass ;
9
10 PREDICATE: class < word "class" word-prop ;
11
12 PREDICATE: defining-class < word "defining-class" word-prop ;
13
14 MIXIN: classoid
15 INSTANCE: class classoid
16 INSTANCE: defining-class classoid
17
18 <PRIVATE
19
20 SYMBOL: class<=-cache
21 SYMBOL: class-not-cache
22 SYMBOL: classes-intersect-cache
23 SYMBOL: class-and-cache
24 SYMBOL: class-or-cache
25 SYMBOL: next-method-quot-cache
26
27 : init-caches ( -- )
28     H{ } clone class<=-cache set
29     H{ } clone class-not-cache set
30     H{ } clone classes-intersect-cache set
31     H{ } clone class-and-cache set
32     H{ } clone class-or-cache set
33     H{ } clone next-method-quot-cache set ;
34
35 : reset-caches ( -- )
36     class<=-cache get clear-assoc
37     class-not-cache get clear-assoc
38     classes-intersect-cache get clear-assoc
39     class-and-cache get clear-assoc
40     class-or-cache get clear-assoc
41     next-method-quot-cache get clear-assoc ;
42
43 SYMBOL: update-map
44
45 SYMBOL: implementors-map
46
47 GENERIC: class-name ( class -- string )
48
49 M: class class-name name>> ;
50
51 GENERIC: rank-class ( class -- n )
52
53 GENERIC: reset-class ( class -- )
54
55 M: class reset-class
56     {
57         "defining-class"
58         "class"
59         "metaclass"
60         "superclass"
61         "members"
62         "participants"
63         "predicate"
64     } remove-word-props ;
65
66 M: word reset-class drop ;
67
68 PRIVATE>
69
70 : classes ( -- seq ) implementors-map get keys ;
71
72 PREDICATE: predicate < word "predicating" word-prop >boolean ;
73
74 : create-predicate-word ( word -- predicate )
75     [ name>> "?" append ] [ vocabulary>> ] bi create-word
76     dup predicate? [ dup reset-generic ] unless ;
77
78 GENERIC: class-of ( object -- class )
79
80 GENERIC: instance? ( object class -- ? ) flushable
81
82 GENERIC: predicate-def ( obj -- quot )
83
84 M: word predicate-def
85     "predicate" word-prop ;
86
87 M: object predicate-def
88     [ instance? ] curry ;
89
90 : predicate-word ( word -- predicate )
91     predicate-def first ;
92
93 M: predicate flushable? drop t ;
94
95 M: predicate forget*
96     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
97
98 M: predicate reset-word
99     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
100
101 : define-predicate ( class quot -- )
102     [ predicate-word ] dip ( object -- ? ) define-declared ;
103
104 : superclass-of ( class -- super )
105     ! Output f for non-classes to work with algebra code
106     dup class? [ "superclass" word-prop ] [ drop f ] if ;
107
108 : superclasses-of ( class -- supers )
109     [ superclass-of ] follow reverse! ;
110
111 : superclass-of? ( class superclass -- ? )
112     superclasses-of member-eq? ;
113
114 : subclass-of? ( class superclass -- ? )
115     swap superclass-of? ;
116
117 : class-members ( class -- seq )
118     #! Output f for non-classes to work with algebra code
119     dup class? [ "members" word-prop ] [ drop f ] if ;
120
121 : class-participants ( class -- seq )
122     #! Output f for non-classes to work with algebra code
123     dup class? [ "participants" word-prop ] [ drop f ] if ;
124
125 GENERIC: implementors ( class/classes -- seq )
126
127 ! update-map
128 : class-uses ( class -- seq )
129     [
130         [ class-members % ]
131         [ class-participants % ]
132         [ superclass-of [ , ] when* ]
133         tri
134     ] { } make ;
135
136 : class-usage ( class -- seq )
137     update-map get at members ;
138
139 <PRIVATE
140
141 : (closure) ( obj set quot: ( elt -- seq ) -- )
142     2over ?adjoin [
143         [ dip ] keep [ (closure) ] 2curry each
144     ] [ 3drop ] if ; inline recursive
145
146 : closure ( obj quot -- set )
147     HS{ } clone [ swap (closure) ] keep ; inline
148
149 PRIVATE>
150
151 : class-usages ( class -- seq )
152     [ class-usage ] closure members ;
153
154 M: class implementors implementors-map get at members ;
155
156 M: sequence implementors [ implementors ] gather ;
157
158 <PRIVATE
159
160 : update-map+ ( class -- )
161     dup class-uses update-map get
162     [ adjoin-at ] curry with each ;
163
164 : update-map- ( class -- )
165     dup class-uses update-map get
166     [ at delete ] curry with each ;
167
168 : implementors-map+ ( class -- )
169     [ HS{ } clone ] dip implementors-map get set-at ;
170
171 : implementors-map- ( class -- )
172     implementors-map get delete-at ;
173
174 : make-class-props ( superclass members participants metaclass -- assoc )
175     [
176         {
177             [ dup [ bootstrap-word ] when "superclass" ,, ]
178             [ [ bootstrap-word ] map "members" ,, ]
179             [ [ bootstrap-word ] map "participants" ,, ]
180             [ "metaclass" ,, ]
181         } spread
182     ] H{ } make ;
183
184 GENERIC: metaclass-changed ( use class -- )
185
186 : ?metaclass-changed ( class usages/f -- )
187     [ [ metaclass-changed ] with each ] [ drop ] if* ;
188
189 : check-metaclass ( class metaclass -- usages/f )
190     over class? [
191         over "metaclass" word-prop eq?
192         [ drop f ] [ class-usage ] if
193     ] [ 2drop f ] if ;
194
195 : ?define-symbol ( word -- )
196     dup deferred? [ define-symbol ] [ drop ] if ;
197
198 : (define-class) ( word props -- )
199     reset-caches
200     2dup "metaclass" of check-metaclass
201     {
202         [ 2drop update-map- ]
203         [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
204         [ 2drop ?define-symbol ]
205         [ drop [ assoc-union ] curry change-props drop ]
206         [
207             2drop
208             dup create-predicate-word
209             [ 1quotation "predicate" set-word-prop ]
210             [ swap "predicating" set-word-prop ]
211             2bi
212         ]
213         [ 2drop t "class" set-word-prop ]
214         [ 2drop update-map+ ]
215         [ nip ?metaclass-changed ]
216     } 3cleave ;
217
218 GENERIC: update-class ( class -- )
219
220 M: class update-class drop ;
221
222 GENERIC: update-methods ( class seq -- )
223
224 : update-classes ( class -- )
225     dup class-usages
226     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
227
228 : check-inheritance ( subclass superclass -- )
229     2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
230
231 : define-class ( word superclass members participants metaclass -- )
232     [ 2dup check-inheritance ] 3dip
233     make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
234
235 : forget-predicate ( class -- )
236     dup predicate-def
237     dup length 1 = [
238         first
239         [ nip ] [ "predicating" word-prop = ] 2bi
240         [ forget ] [ drop ] if
241     ] [ 2drop ] if ;
242
243 GENERIC: forget-methods ( class -- )
244
245 PRIVATE>
246
247 : forget-class ( class -- )
248     dup f check-metaclass {
249         [ drop forget-predicate ]
250         [ drop forget-methods ]
251         [ drop implementors-map- ]
252         [ drop update-map- ]
253         [ drop reset-class ]
254         [ 2drop reset-caches ]
255         [ ?metaclass-changed ]
256     } 2cleave ;
257
258 M: class metaclass-changed
259     swap class? [ drop ] [ forget-class ] if ;
260
261 M: class forget* ( class -- )
262     [ call-next-method ] [ forget-class ] bi ;