1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions hashtables kernel kernel.private math
4 namespaces make sequences sequences.private strings vectors
5 words quotations memory combinators generic classes
6 classes.algebra classes.algebra.private classes.builtin
7 classes.private slots.private slots math.private accessors
11 PREDICATE: tuple-class < class
12 "metaclass" word-prop tuple-class eq? ;
14 ERROR: not-a-tuple object ;
16 : all-slots ( class -- slots )
17 superclasses [ "slots" word-prop ] map concat ;
19 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
20 all-slots [ read-only>> ] all? ;
24 : tuple-layout ( class -- layout )
27 : layout-of ( tuple -- layout )
28 1 slot { array } declare ; inline
30 M: tuple class layout-of 2 slot { word } declare ; inline
32 : tuple-size ( tuple -- size )
33 layout-of 3 slot { fixnum } declare ; inline
35 : layout-up-to-date? ( object -- ? )
37 [ [ layout-of ] [ class tuple-layout ] bi eq? ] [ drop t ] if ;
39 : check-tuple ( object -- tuple )
40 dup tuple? [ not-a-tuple ] unless ; inline
42 : prepare-tuple>array ( tuple -- n tuple layout )
43 check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
45 : copy-tuple-slots ( n tuple -- array )
46 [ array-nth ] curry map ;
48 : check-slots ( seq class -- seq class )
51 class>> 2dup instance?
52 [ 2drop ] [ bad-slot-value ] if
54 ] if-bootstrapping ; inline
56 : initial-values ( class -- slots )
57 all-slots [ initial>> ] map ;
59 : pad-slots ( slots class -- slots' class )
60 [ initial-values over length tail append ] keep ; inline
64 : tuple>array ( tuple -- array )
66 [ copy-tuple-slots ] dip
69 : tuple-slots ( tuple -- seq )
70 prepare-tuple>array drop copy-tuple-slots ;
72 GENERIC: slots>tuple ( seq class -- tuple )
74 M: tuple-class slots>tuple ( seq class -- tuple )
76 tuple-layout <tuple> [
78 [ [ set-array-nth ] curry ]
82 : >tuple ( seq -- tuple )
85 ERROR: bad-superclass class ;
87 : tuple= ( tuple1 tuple2 -- ? )
88 2dup [ tuple? ] both? [
89 2dup [ layout-of ] bi@ eq? [
91 [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
94 ] [ 2drop f ] if ; inline
96 GENERIC: final-class? ( class -- ? )
98 M: tuple-class final-class? "final" word-prop ;
100 M: builtin-class final-class? tuple eq? not ;
102 M: class final-class? drop t ;
106 : tuple-predicate-quot/1 ( class -- quot )
107 #! Fast path for tuples with no superclass
108 [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
109 [ dup tuple? ] [ [ drop f ] if ] surround ;
111 : tuple-instance? ( object class offset -- ? )
115 [ swap slot eq? ] [ 3drop f ] if
116 ] [ 3drop f ] if ; inline
118 : layout-class-offset ( echelon -- n )
121 : tuple-predicate-quot ( class echelon -- quot )
122 layout-class-offset [ tuple-instance? ] 2curry ;
124 : echelon-of ( class -- n )
127 : define-tuple-predicate ( class -- )
129 { 1 [ tuple-predicate-quot/1 ] }
130 [ tuple-predicate-quot ]
131 } case define-predicate ;
133 : class-size ( class -- n )
134 superclasses [ "slots" word-prop length ] map-sum ;
136 : boa-check-quot ( class -- quot )
137 all-slots [ class>> instance-check-quot ] map shallow-spread>quot
140 : define-boa-check ( class -- )
141 dup boa-check-quot "boa-check" set-word-prop ;
143 : tuple-prototype ( class -- prototype )
144 [ initial-values ] keep over [ ] any?
145 [ slots>tuple ] [ 2drop f ] if ;
147 : define-tuple-prototype ( class -- )
148 dup tuple-prototype "prototype" set-word-prop ;
150 : prepare-slots ( slots superclass -- slots' )
151 [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
153 : define-tuple-slots ( class -- )
154 dup "slots" word-prop over superclass prepare-slots
157 : make-tuple-layout ( class -- layout )
161 [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
162 [ superclasses length 1 - , ]
163 [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
167 : define-tuple-layout ( class -- )
168 dup make-tuple-layout "layout" set-word-prop ;
170 : compute-slot-permutation ( new-slots old-slots -- triples )
171 [ [ [ name>> ] map ] bi@ [ index ] curry map ]
172 [ drop [ class>> ] map ]
173 [ drop [ initial>> ] map ]
176 : update-slot ( old-values n class initial -- value )
178 [ [ swap nth dup ] dip instance? ] dip swap
180 ] [ [ 3drop ] dip ] if ;
182 : apply-slot-permutation ( old-values triples -- new-values )
183 [ first3 update-slot ] with map ;
185 SYMBOL: outdated-tuples
187 : permute-slots ( old-values layout -- new-values )
188 [ first all-slots ] [ outdated-tuples get at ] bi
189 compute-slot-permutation
190 apply-slot-permutation ;
192 : update-tuple ( tuple -- newtuple )
193 [ tuple-slots ] [ layout-of ] bi
194 [ permute-slots ] [ first ] bi
197 : outdated-tuple? ( tuple assoc -- ? )
198 [ [ layout-of ] dip key? ]
199 [ drop class "forgotten" word-prop not ]
202 : update-tuples ( -- )
204 dup assoc-empty? [ drop ] [
205 [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
206 dup [ update-tuple ] map become
209 : update-tuples-after ( class -- )
210 [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
212 M: tuple-class update-class
215 [ define-tuple-layout ]
216 [ define-tuple-slots ]
217 [ define-tuple-predicate ]
218 [ define-tuple-prototype ]
221 : define-new-tuple-class ( class superclass slots -- )
222 [ drop f f tuple-class define-class ]
223 [ nip "slots" set-word-prop ]
224 [ 2drop update-classes ]
227 : subclasses ( class -- classes )
228 class-usages [ tuple-class? ] filter ;
230 : each-subclass ( class quot -- )
231 [ subclasses ] dip each ; inline
233 : redefine-tuple-class ( class superclass slots -- )
237 [ update-tuples-after ]
238 [ changed-conditionally ]
242 [ define-new-tuple-class ] 3bi ;
244 : tuple-class-unchanged? ( class superclass slots -- ? )
245 [ [ superclass ] [ bootstrap-word ] bi* = ]
246 [ [ "slots" word-prop ] dip = ]
249 : check-superclass ( superclass -- )
250 dup final-class? [ bad-superclass ] when drop ;
252 GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
254 : thrower-effect ( slots -- effect )
255 [ name>> ] map { "*" } <effect> ;
257 : error-slots ( slots -- slots' )
259 dup string? [ 1array ] when
260 read-only swap remove
264 : reset-final ( class -- )
266 [ f "final" set-word-prop ]
267 [ changed-conditionally ]
273 : define-tuple-class ( class superclass slots -- )
274 over check-superclass
276 (define-tuple-class) ;
278 GENERIC: make-final ( class -- )
280 M: tuple-class make-final
281 [ dup class-usage keys ?metaclass-changed ]
282 [ t "final" set-word-prop ]
285 M: word (define-tuple-class)
286 define-new-tuple-class ;
288 M: tuple-class (define-tuple-class)
290 3dup tuple-class-unchanged?
291 [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
293 PREDICATE: error-class < tuple-class
294 "error-class" word-prop ;
296 M: error-class reset-class
297 [ call-next-method ] [ "error-class" remove-word-prop ] bi ;
299 : define-error-class ( class superclass slots -- )
301 [ define-tuple-class ]
302 [ 2drop reset-generic ]
303 [ 2drop t "error-class" set-word-prop ]
306 [ dup [ boa throw ] curry ]
307 [ all-slots thrower-effect ]
312 : boa-effect ( class -- effect )
313 [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
315 : define-boa-word ( word class -- )
316 [ [ boa ] curry ] [ boa-effect ] bi define-inline ;
318 : forget-slot-accessors ( class slots -- )
321 [ reader-word ?lookup-method forget ]
322 [ writer-word ?lookup-method forget ] 2bi
325 M: tuple-class reset-class
327 dup "slots" word-prop forget-slot-accessors
330 [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
334 M: tuple-class metaclass-changed
335 ! Our superclass is no longer a tuple class, redefine with
337 nip tuple over "slots" word-prop define-tuple-class ;
339 M: tuple-class rank-class drop 1 ;
341 M: tuple-class instance?
342 dup echelon-of layout-class-offset tuple-instance? ;
344 M: tuple-class (flatten-class) dup set ;
346 M: tuple-class (classes-intersect?)
348 { [ over builtin-class? ] [ drop tuple eq? ] }
349 { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
352 M: tuple clone (clone) ; inline
354 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
356 : tuple-hashcode ( depth obj -- hash )
359 [ class hashcode ] [ tuple-size ] bi
360 [ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi
362 swapd array-nth hashcode* >fixnum rot fixnum-bitxor
363 pick fixnum*fast [ [ fixnum+fast ] keep ] dip swap
364 ] 2curry each drop nip 97531 fixnum+fast ; inline
366 M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
369 dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
372 [ "boa-check" word-prop [ call ] when* ]
376 M: tuple-class initial-value* new ;