1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators definitions graphs kernel
4 make namespaces quotations sequences sets words words.symbol ;
7 ERROR: bad-inheritance class superclass ;
9 PREDICATE: class < word "class" word-prop ;
11 PREDICATE: defining-class < word "defining-class" word-prop ;
14 INSTANCE: class classoid
15 INSTANCE: defining-class classoid
20 SYMBOL: class-not-cache
21 SYMBOL: classes-intersect-cache
22 SYMBOL: class-and-cache
23 SYMBOL: class-or-cache
24 SYMBOL: next-method-quot-cache
27 H{ } clone class<=-cache namespaces:set
28 H{ } clone class-not-cache namespaces:set
29 H{ } clone classes-intersect-cache namespaces:set
30 H{ } clone class-and-cache namespaces:set
31 H{ } clone class-or-cache namespaces:set
32 H{ } clone next-method-quot-cache namespaces:set ;
35 class<=-cache get clear-assoc
36 class-not-cache get clear-assoc
37 classes-intersect-cache get clear-assoc
38 class-and-cache get clear-assoc
39 class-or-cache get clear-assoc
40 next-method-quot-cache get clear-assoc ;
44 SYMBOL: implementors-map
46 GENERIC: class-name ( class -- string )
48 M: class class-name name>> ;
50 GENERIC: rank-class ( class -- n )
52 GENERIC: reset-class ( class -- )
65 M: word reset-class drop ;
69 : classes ( -- seq ) implementors-map get keys ;
71 PREDICATE: predicate < word "predicating" word-prop >boolean ;
73 : create-predicate-word ( word -- predicate )
74 [ name>> "?" append ] [ vocabulary>> ] bi create-word
75 dup predicate? [ dup reset-generic ] unless ;
77 GENERIC: class-of ( object -- class )
79 GENERIC: instance? ( object class -- ? ) flushable
81 GENERIC: predicate-def ( obj -- quot )
84 "predicate" word-prop ;
86 M: object predicate-def
89 : predicate-word ( word -- predicate )
92 M: predicate flushable? drop t ;
95 [ call-next-method ] [ "predicating" remove-word-prop ] bi ;
97 M: predicate reset-word
98 [ call-next-method ] [ "predicating" remove-word-prop ] bi ;
100 : define-predicate ( class quot -- )
101 [ predicate-word ] dip ( object -- ? ) define-declared ;
103 : superclass-of ( class -- super )
104 ! Output f for non-classes to work with algebra code
105 dup class? [ "superclass" word-prop ] [ drop f ] if ;
107 : superclasses-of ( class -- supers )
108 [ superclass-of ] follow reverse! ;
110 : superclass-of? ( class superclass -- ? )
111 superclasses-of member-eq? ;
113 : subclass-of? ( class superclass -- ? )
114 swap superclass-of? ;
116 : class-members ( class -- seq )
117 ! Output f for non-classes to work with algebra code
118 dup class? [ "members" word-prop ] [ drop f ] if ;
120 : class-participants ( class -- seq )
121 ! Output f for non-classes to work with algebra code
122 dup class? [ "participants" word-prop ] [ drop f ] if ;
124 GENERIC: contained-classes ( obj -- members )
126 M: object contained-classes
127 "members" word-prop ;
129 : all-contained-classes ( members -- members' )
130 dup dup [ contained-classes ] map concat sift append
131 2dup set= [ drop members ] [ nip all-contained-classes ] if ;
133 GENERIC: implementors ( class/classes -- seq )
136 : class-uses ( class -- seq )
139 [ class-participants % ]
140 [ superclass-of [ , ] when* ]
144 : class-usage ( class -- seq )
145 update-map get at members ;
147 : class-usages ( class -- seq )
148 [ class-usage ] closure members ;
150 M: class implementors implementors-map get at members ;
152 M: sequence implementors [ implementors ] gather ;
156 : update-map+ ( class -- )
157 dup class-uses update-map get add-vertex ;
159 : update-map- ( class -- )
160 dup class-uses update-map get remove-vertex ;
162 : implementors-map+ ( class -- )
163 [ HS{ } clone ] dip implementors-map get set-at ;
165 : implementors-map- ( class -- )
166 implementors-map get delete-at ;
168 : make-class-props ( superclass members participants metaclass -- assoc )
171 [ dup [ bootstrap-word ] when "superclass" ,, ]
172 [ [ bootstrap-word ] map "members" ,, ]
173 [ [ bootstrap-word ] map "participants" ,, ]
178 GENERIC: metaclass-changed ( use class -- )
180 : ?metaclass-changed ( class usages/f -- )
181 [ [ metaclass-changed ] with each ] [ drop ] if* ;
183 : check-metaclass ( class metaclass -- usages/f )
185 over "metaclass" word-prop eq?
186 [ drop f ] [ class-usage ] if
189 : ?define-symbol ( word -- )
190 dup deferred? [ define-symbol ] [ drop ] if ;
192 : (define-class) ( word props -- )
194 2dup "metaclass" of check-metaclass
196 [ 2drop update-map- ]
197 [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
198 [ 2drop ?define-symbol ]
199 [ drop [ assoc-union ] curry change-props drop ]
202 dup create-predicate-word
203 [ 1quotation "predicate" set-word-prop ]
204 [ swap "predicating" set-word-prop ]
207 [ 2drop t "class" set-word-prop ]
208 [ 2drop f "defining-class" set-word-prop ]
209 [ 2drop update-map+ ]
210 [ nip ?metaclass-changed ]
213 GENERIC: update-class ( class -- )
215 M: class update-class drop ;
217 GENERIC: update-methods ( class seq -- )
219 : update-classes ( class -- )
221 [ nip [ update-class ] each ] [ update-methods ] 2bi ;
223 : check-inheritance ( subclass superclass -- subclass superclass )
224 2dup superclass-of? [ bad-inheritance ] when ;
226 : define-class ( word superclass members participants metaclass -- )
227 [ check-inheritance ] 3dip
228 make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
230 : forget-predicate ( class -- )
234 [ nip ] [ "predicating" word-prop = ] 2bi
235 [ forget ] [ drop ] if
238 GENERIC: forget-methods ( class -- )
242 : forget-class ( class -- )
243 dup f check-metaclass {
244 [ drop forget-predicate ]
245 [ drop forget-methods ]
246 [ drop implementors-map- ]
249 [ 2drop reset-caches ]
250 [ ?metaclass-changed ]
253 M: class metaclass-changed
254 swap class? [ drop ] [ forget-class ] if ;
257 [ call-next-method ] [ forget-class ] bi ;
259 ERROR: not-an-instance obj class ;
261 : check-instance ( obj class -- obj )
262 [ dupd instance? ] keep [ not-an-instance ] curry unless ; inline