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 ;
9 ERROR: bad-inheritance class superclass ;
11 PREDICATE: class < word "class" word-prop ;
13 PREDICATE: defining-class < word "defining-class" word-prop ;
16 INSTANCE: class classoid
17 INSTANCE: defining-class classoid
22 SYMBOL: class-not-cache
23 SYMBOL: classes-intersect-cache
24 SYMBOL: class-and-cache
25 SYMBOL: class-or-cache
26 SYMBOL: next-method-quot-cache
29 H{ } clone class<=-cache set
30 H{ } clone class-not-cache set
31 H{ } clone classes-intersect-cache set
32 H{ } clone class-and-cache set
33 H{ } clone class-or-cache set
34 H{ } clone next-method-quot-cache set ;
37 class<=-cache get clear-assoc
38 class-not-cache get clear-assoc
39 classes-intersect-cache get clear-assoc
40 class-and-cache get clear-assoc
41 class-or-cache get clear-assoc
42 next-method-quot-cache get clear-assoc ;
46 SYMBOL: implementors-map
48 GENERIC: class-name ( class -- string )
50 M: class class-name name>> ;
52 GENERIC: rank-class ( class -- n )
54 GENERIC: reset-class ( class -- )
67 M: word reset-class drop ;
71 : classes ( -- seq ) implementors-map get keys ;
73 PREDICATE: predicate < word "predicating" word-prop >boolean ;
75 : create-predicate-word ( word -- predicate )
76 [ name>> "?" append ] [ vocabulary>> ] bi create
77 dup predicate? [ dup reset-generic ] unless ;
79 GENERIC: class-of ( object -- class )
81 GENERIC: instance? ( object class -- ? ) flushable
83 GENERIC: predicate-def ( obj -- quot )
86 "predicate" word-prop ;
88 M: object predicate-def
91 : predicate-word ( word -- predicate )
94 M: predicate flushable? drop t ;
97 [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
99 M: predicate reset-word
100 [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
102 : define-predicate ( class quot -- )
103 [ predicate-word ] dip ( object -- ? ) define-declared ;
105 : superclass ( class -- super )
106 #! Output f for non-classes to work with algebra code
107 dup class? [ "superclass" word-prop ] [ drop f ] if ;
109 : superclasses ( class -- supers )
110 [ superclass ] follow reverse! ;
112 : superclass-of? ( class superclass -- ? )
113 superclasses member-eq? ;
115 : subclass-of? ( class superclass -- ? )
116 swap superclass-of? ;
118 : members ( class -- seq )
119 #! Output f for non-classes to work with algebra code
120 dup class? [ "members" word-prop ] [ drop f ] if ;
122 : participants ( class -- seq )
123 #! Output f for non-classes to work with algebra code
124 dup class? [ "participants" word-prop ] [ drop f ] if ;
126 GENERIC: implementors ( class/classes -- seq )
129 : class-uses ( class -- seq )
133 [ superclass [ , ] when* ]
137 : class-usage ( class -- seq )
138 update-map get at sets:members ;
142 : (closure) ( obj set quot: ( elt -- seq ) -- )
144 [ dip ] keep [ (closure) ] 2curry each
145 ] [ 3drop ] if ; inline recursive
147 : closure ( obj quot -- set )
148 HS{ } clone [ swap (closure) ] keep ; inline
152 : class-usages ( class -- seq )
153 [ class-usage ] closure sets:members ;
155 M: class implementors implementors-map get at sets:members ;
157 M: sequence implementors [ implementors ] gather ;
161 : update-map+ ( class -- )
162 dup class-uses update-map get
163 [ adjoin-at ] curry with each ;
165 : update-map- ( class -- )
166 dup class-uses update-map get
167 [ at delete ] curry with each ;
169 : implementors-map+ ( class -- )
170 [ HS{ } clone ] dip implementors-map get set-at ;
172 : implementors-map- ( class -- )
173 implementors-map get delete-at ;
175 : make-class-props ( superclass members participants metaclass -- assoc )
178 [ dup [ bootstrap-word ] when "superclass" ,, ]
179 [ [ bootstrap-word ] map "members" ,, ]
180 [ [ bootstrap-word ] map "participants" ,, ]
185 GENERIC: metaclass-changed ( use class -- )
187 : ?metaclass-changed ( class usages/f -- )
188 dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
190 : check-metaclass ( class metaclass -- usages/f )
192 over "metaclass" word-prop eq?
193 [ drop f ] [ class-usage ] if
196 : ?define-symbol ( word -- )
197 dup deferred? [ define-symbol ] [ drop ] if ;
199 : (define-class) ( word props -- )
201 2dup "metaclass" of check-metaclass
203 [ 2drop update-map- ]
204 [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
205 [ 2drop ?define-symbol ]
206 [ drop [ assoc-union ] curry change-props drop ]
209 dup create-predicate-word
210 [ 1quotation "predicate" set-word-prop ]
211 [ swap "predicating" set-word-prop ]
214 [ 2drop t "class" set-word-prop ]
215 [ 2drop update-map+ ]
216 [ nip ?metaclass-changed ]
219 GENERIC: update-class ( class -- )
221 M: class update-class drop ;
223 GENERIC: update-methods ( class seq -- )
225 : update-classes ( class -- )
227 [ nip [ update-class ] each ] [ update-methods ] 2bi ;
229 : check-inheritance ( subclass superclass -- )
230 2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
232 : define-class ( word superclass members participants metaclass -- )
233 [ 2dup check-inheritance ] 3dip
234 make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
236 : forget-predicate ( class -- )
240 [ nip ] [ "predicating" word-prop = ] 2bi
241 [ forget ] [ drop ] if
244 GENERIC: forget-methods ( class -- )
248 : forget-class ( class -- )
249 dup f check-metaclass {
250 [ drop forget-predicate ]
251 [ drop forget-methods ]
252 [ drop implementors-map- ]
255 [ 2drop reset-caches ]
256 [ ?metaclass-changed ]
259 M: class metaclass-changed
260 swap class? [ drop ] [ forget-class ] if ;
262 M: class forget* ( class -- )
263 [ call-next-method ] [ forget-class ] bi ;