1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
4 ! for classes.union mutual dependency
9 DEFER: layout-class-offset
12 USING: accessors arrays assocs classes classes.algebra
13 classes.algebra.private classes.builtin classes.private
14 combinators definitions effects generic kernel kernel.private
15 make math math.private memory namespaces quotations
16 sequences sequences.private slots slots.private strings words ;
19 PRIMITIVE: <tuple> ( layout -- tuple )
20 PRIMITIVE: <tuple-boa> ( slots... layout -- tuple )
23 PREDICATE: tuple-class < class
24 "metaclass" word-prop tuple-class eq? ;
26 ERROR: too-many-slots class slots got max ;
28 : all-slots ( class -- slots )
29 superclasses-of [ "slots" word-prop ] map concat ;
31 ERROR: no-slot name tuple ;
33 : ?offset-of-slot ( name tuple -- n/f )
34 class-of all-slots slot-named [ offset>> ] [ f ] if* ;
36 : offset-of-slot ( name tuple -- n )
37 2dup ?offset-of-slot [ 2nip ] [ no-slot ] if* ;
39 : get-slot-named ( name tuple -- value )
40 [ nip ] [ offset-of-slot ] 2bi slot ;
42 : set-slot-named ( value name tuple -- )
43 [ nip ] [ offset-of-slot ] 2bi set-slot ;
45 : set-slots ( assoc tuple -- )
46 [ swapd set-slot-named ] curry assoc-each ; inline
48 : from-slots ( assoc class -- tuple )
49 new [ set-slots ] keep ; inline
51 PREDICATE: immutable-tuple-class < tuple-class
52 all-slots [ read-only>> ] all? ;
56 : tuple-layout ( class -- layout )
59 : layout-of ( tuple -- layout )
60 1 slot { array } declare ; inline
62 M: tuple class-of layout-of 2 slot { word } declare ; inline
64 : tuple-size ( tuple -- size )
65 layout-of 3 slot { fixnum } declare ; inline
67 : layout-up-to-date? ( object -- ? )
69 [ layout-of ] [ class-of tuple-layout ] bi eq?
72 : prepare-tuple-slots ( tuple -- n tuple )
73 tuple check-instance [ tuple-size <iota> ] keep ;
75 : copy-tuple-slots ( n tuple -- array )
76 [ array-nth ] curry map ;
78 : check-slots ( seq class -- seq class )
81 class>> 2dup instance?
82 [ 2drop ] [ bad-slot-value ] if
84 ] if-bootstrapping ; inline
86 : pad-slots ( seq class -- seq' class )
87 [ all-slots ] keep 2over 2length 2dup > [
88 [ nip swap ] 2dip too-many-slots
91 tail-slice [ [ initial>> ] map append ] unless-empty
95 : make-tuple ( seq class -- tuple )
96 tuple-layout <tuple> [
98 [ [ set-array-nth ] curry ]
104 : tuple-slots ( tuple -- seq )
105 prepare-tuple-slots copy-tuple-slots ;
107 GENERIC: slots>tuple ( seq class -- tuple )
109 M: tuple-class slots>tuple
110 check-slots pad-slots make-tuple ;
112 : tuple>array ( tuple -- array )
113 [ tuple-slots ] [ class-of prefix ] bi ;
115 : >tuple ( seq -- tuple )
118 ERROR: bad-superclass class ;
120 : tuple= ( tuple1 tuple2 -- ? )
121 2dup [ tuple? ] both? [
122 2dup [ layout-of ] bi@ eq? [
124 [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
127 ] [ 2drop f ] if ; inline
129 GENERIC: final-class? ( object -- ? )
131 M: tuple-class final-class? "final" word-prop ;
133 M: builtin-class final-class? tuple eq? not ;
135 M: class final-class? drop t ;
137 M: object final-class? drop f ;
141 : tuple-predicate-quot/1 ( class -- quot )
142 ! Fast path for tuples with no superclass
143 [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
144 [ dup tuple? ] [ [ drop f ] if ] surround ;
146 : tuple-instance? ( object class offset -- ? )
150 [ swap slot eq? ] [ 3drop f ] if
151 ] [ 3drop f ] if ; inline
153 : layout-class-offset ( echelon -- n )
156 : tuple-predicate-quot ( class echelon -- quot )
157 layout-class-offset [ tuple-instance? ] 2curry ;
159 : echelon-of ( class -- n )
162 : define-tuple-predicate ( class -- )
164 { 1 [ tuple-predicate-quot/1 ] }
165 [ tuple-predicate-quot ]
166 } case define-predicate ;
168 : class-size ( class -- n )
169 superclasses-of [ "slots" word-prop length ] map-sum ;
171 : boa-check-quot ( class -- quot )
172 all-slots [ class>> instance-check-quot ] map shallow-spread>quot
175 : define-boa-check ( class -- )
176 dup boa-check-quot "boa-check" set-word-prop ;
178 : initial-values ( class -- seq )
179 all-slots [ initial>> ] map ; inline
181 : tuple-prototype ( class -- prototype )
182 [ initial-values ] keep over [ ] any?
183 [ slots>tuple ] [ 2drop f ] if ;
185 : define-tuple-prototype ( class -- )
186 dup tuple-prototype "prototype" set-word-prop ;
188 : prepare-slots ( slots superclass -- slots' )
189 [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
191 : define-tuple-slots ( class -- )
192 dup "slots" word-prop over superclass-of prepare-slots
195 : make-tuple-layout ( class -- layout )
199 [ [ superclass-of class-size ] [ "slots" word-prop length ] bi + , ]
200 [ superclasses-of length 1 - , ]
201 [ superclasses-of [ [ , ] [ hashcode , ] bi ] each ]
205 : define-tuple-layout ( class -- )
206 dup make-tuple-layout "layout" set-word-prop ;
208 : compute-slot-permutation ( new-slots old-slots -- triples )
209 [ [ [ name>> ] map ] bi@ [ index ] curry map ]
210 [ drop [ class>> ] map ]
211 [ drop [ initial>> ] map ]
214 : update-slot ( old-values n class initial -- value )
216 [ [ swap nth dup ] dip instance? ] dip swap
220 : apply-slot-permutation ( old-values triples -- new-values )
221 [ first3 update-slot ] with map ;
223 SYMBOL: outdated-tuples
225 : permute-slots ( old-values layout -- new-values )
226 [ first all-slots ] [ outdated-tuples get at ] bi
227 compute-slot-permutation
228 apply-slot-permutation ;
230 GENERIC: update-tuple ( tuple -- newtuple )
232 M: tuple update-tuple
233 [ tuple-slots ] [ layout-of ] bi
234 [ permute-slots ] [ first ] bi
237 : outdated-tuple? ( tuple assoc -- ? )
238 [ [ layout-of ] dip key? ]
239 [ drop class-of "forgotten" word-prop not ]
242 : update-tuples ( outdated-tuples -- )
243 dup assoc-empty? [ drop ] [
244 '[ dup tuple? [ _ outdated-tuple? ] [ drop f ] if ] instances
245 dup [ update-tuple ] map become
248 : update-tuples-after ( class -- )
249 [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
251 M: tuple-class update-class
254 [ define-tuple-layout ]
255 [ define-tuple-slots ]
256 [ define-tuple-predicate ]
257 [ define-tuple-prototype ]
260 : define-new-tuple-class ( class superclass slots -- )
261 [ drop f f tuple-class define-class ]
262 [ nip "slots" set-word-prop ]
263 [ 2drop update-classes ] 3tri ;
265 : subclasses ( class -- classes )
266 class-usages [ tuple-class? ] filter ;
268 : each-subclass ( class quot -- )
269 [ subclasses ] dip each ; inline
271 : redefine-tuple-class ( class superclass slots -- )
275 [ update-tuples-after ]
276 [ changed-conditionally ]
280 [ define-new-tuple-class ] 3bi ;
282 : tuple-class-unchanged? ( class superclass slots -- ? )
283 [ [ superclass-of ] [ bootstrap-word ] bi* = ]
284 [ [ "slots" word-prop ] dip = ]
287 : check-superclass ( superclass -- )
288 dup final-class? [ bad-superclass ] when
289 dup class? [ bad-superclass ] unless drop ;
291 GENERIC#: (define-tuple-class) 2 ( class superclass slots -- )
293 : thrower-effect ( slots -- effect )
294 [ name>> ] map { "*" } <effect> ;
296 : error-slots ( slots -- slots' )
298 dup string? [ 1array ] when
299 read-only swap remove
303 : reset-final ( class -- )
305 [ "final" remove-word-prop ]
306 [ changed-conditionally ]
312 : define-tuple-class ( class superclass slots -- )
313 over check-superclass
315 (define-tuple-class) ;
317 GENERIC: make-final ( class -- )
319 M: tuple-class make-final
320 [ dup class-usage ?metaclass-changed ]
321 [ t "final" set-word-prop ]
324 M: word (define-tuple-class)
325 define-new-tuple-class ;
327 M: tuple-class (define-tuple-class)
329 3dup tuple-class-unchanged?
330 [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
332 GENERIC: boa-effect ( class -- effect )
334 M: tuple-class boa-effect
335 [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
337 : define-boa-word ( word class -- )
338 tuple-class check-instance
339 [ [ boa ] curry ] [ boa-effect ] bi
342 : forget-slot-accessors ( class slots -- )
345 [ reader-word ?lookup-method forget ]
346 [ writer-word ?lookup-method forget ] 2bi
349 M: tuple-class reset-class
351 dup "slots" word-prop forget-slot-accessors
354 [ { "layout" "slots" "boa-check" "prototype" "final" } remove-word-props ]
358 M: tuple-class metaclass-changed
359 ! Our superclass is no longer a tuple class, redefine with
361 nip tuple over "slots" word-prop define-tuple-class ;
363 M: tuple-class rank-class drop 1 ;
365 M: tuple-class instance?
366 dup echelon-of layout-class-offset tuple-instance? ;
368 M: tuple-class (flatten-class) , ;
370 M: tuple-class (classes-intersect?)
372 { [ over builtin-class? ] [ drop tuple eq? ] }
373 { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
376 M: tuple clone (clone) ; inline
378 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
380 : tuple-hashcode ( depth obj -- hash )
383 [ class-of hashcode ] [ tuple-size ] bi
384 [ dup fixnum+fast 82520 fixnum+fast ] [ <iota> ] bi
386 swapd array-nth hashcode* integer>fixnum rot fixnum-bitxor
387 pick fixnum*fast [ [ fixnum+fast ] keep ] dip swap
388 ] 2curry each drop nip 97531 fixnum+fast ; inline
390 M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
393 dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
396 [ "boa-check" word-prop [ call ] when* ]
400 M: tuple-class initial-value* new t ;