1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.algebra
4 classes.algebra.private classes.builtin classes.private
5 combinators definitions effects generic kernel kernel.private
6 make math math.private memory namespaces quotations sequences
7 sequences.private slots slots.private strings words ;
10 PREDICATE: tuple-class < class
11 "metaclass" word-prop tuple-class eq? ;
13 ERROR: not-a-tuple object ;
15 : all-slots ( class -- slots )
16 superclasses [ "slots" word-prop ] map concat ;
18 ERROR: no-slot name tuple ;
20 : offset-of-slot ( name tuple -- n )
21 2dup class-of all-slots slot-named
22 [ 2nip offset>> ] [ no-slot ] if* ;
24 : get-slot-named ( name tuple -- value )
25 [ nip ] [ offset-of-slot ] 2bi slot ;
27 : set-slot-named ( value name tuple -- )
28 [ nip ] [ offset-of-slot ] 2bi set-slot ;
30 : set-slots ( assoc tuple -- )
31 [ swapd set-slot-named ] curry assoc-each ; inline
33 : from-slots ( assoc class -- tuple )
34 new [ set-slots ] keep ; inline
36 PREDICATE: immutable-tuple-class < tuple-class
37 all-slots [ read-only>> ] all? ;
41 : tuple-layout ( class -- layout )
44 : layout-of ( tuple -- layout )
45 1 slot { array } declare ; inline
47 M: tuple class-of layout-of 2 slot { word } declare ; inline
49 : tuple-size ( tuple -- size )
50 layout-of 3 slot { fixnum } declare ; inline
52 : layout-up-to-date? ( object -- ? )
54 [ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
56 : check-tuple ( object -- tuple )
57 dup tuple? [ not-a-tuple ] unless ; inline
59 : prepare-tuple-slots ( tuple -- n tuple )
60 check-tuple [ tuple-size iota ] keep ;
62 : copy-tuple-slots ( n tuple -- array )
63 [ array-nth ] curry map ;
65 : check-slots ( seq class -- seq class )
68 class>> 2dup instance?
69 [ 2drop ] [ bad-slot-value ] if
71 ] if-bootstrapping ; inline
73 : initial-values ( class -- slots )
74 all-slots [ initial>> ] map ;
76 : pad-slots ( slots class -- slots' class )
77 [ initial-values over length tail append ] keep ; inline
81 : tuple-slots ( tuple -- seq )
82 prepare-tuple-slots copy-tuple-slots ;
84 GENERIC: slots>tuple ( seq class -- tuple )
86 M: tuple-class slots>tuple ( seq class -- tuple )
88 tuple-layout <tuple> [
90 [ [ set-array-nth ] curry ]
94 : tuple>array ( tuple -- array )
95 [ tuple-slots ] [ layout-of first prefix ] bi ;
97 : >tuple ( seq -- tuple )
100 ERROR: bad-superclass class ;
102 : tuple= ( tuple1 tuple2 -- ? )
103 2dup [ tuple? ] both? [
104 2dup [ layout-of ] bi@ eq? [
106 [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
109 ] [ 2drop f ] if ; inline
111 GENERIC: final-class? ( object -- ? )
113 M: tuple-class final-class? "final" word-prop ;
115 M: builtin-class final-class? tuple eq? not ;
117 M: class final-class? drop t ;
119 M: object final-class? drop f ;
123 : tuple-predicate-quot/1 ( class -- quot )
124 #! Fast path for tuples with no superclass
125 [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
126 [ dup tuple? ] [ [ drop f ] if ] surround ;
128 : tuple-instance? ( object class offset -- ? )
132 [ swap slot eq? ] [ 3drop f ] if
133 ] [ 3drop f ] if ; inline
135 : layout-class-offset ( echelon -- n )
138 : tuple-predicate-quot ( class echelon -- quot )
139 layout-class-offset [ tuple-instance? ] 2curry ;
141 : echelon-of ( class -- n )
144 : define-tuple-predicate ( class -- )
146 { 1 [ tuple-predicate-quot/1 ] }
147 [ tuple-predicate-quot ]
148 } case define-predicate ;
150 : class-size ( class -- n )
151 superclasses [ "slots" word-prop length ] map-sum ;
153 : boa-check-quot ( class -- quot )
154 all-slots [ class>> instance-check-quot ] map shallow-spread>quot
157 : define-boa-check ( class -- )
158 dup boa-check-quot "boa-check" set-word-prop ;
160 : tuple-prototype ( class -- prototype )
161 [ initial-values ] keep over [ ] any?
162 [ slots>tuple ] [ 2drop f ] if ;
164 : define-tuple-prototype ( class -- )
165 dup tuple-prototype "prototype" set-word-prop ;
167 : prepare-slots ( slots superclass -- slots' )
168 [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
170 : define-tuple-slots ( class -- )
171 dup "slots" word-prop over superclass prepare-slots
174 : make-tuple-layout ( class -- layout )
178 [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
179 [ superclasses length 1 - , ]
180 [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
184 : define-tuple-layout ( class -- )
185 dup make-tuple-layout "layout" set-word-prop ;
187 : compute-slot-permutation ( new-slots old-slots -- triples )
188 [ [ [ name>> ] map ] bi@ [ index ] curry map ]
189 [ drop [ class>> ] map ]
190 [ drop [ initial>> ] map ]
193 : update-slot ( old-values n class initial -- value )
195 [ [ swap nth dup ] dip instance? ] dip swap
197 ] [ [ 3drop ] dip ] if ;
199 : apply-slot-permutation ( old-values triples -- new-values )
200 [ first3 update-slot ] with map ;
202 SYMBOL: outdated-tuples
204 : permute-slots ( old-values layout -- new-values )
205 [ first all-slots ] [ outdated-tuples get at ] bi
206 compute-slot-permutation
207 apply-slot-permutation ;
209 : update-tuple ( tuple -- newtuple )
210 [ tuple-slots ] [ layout-of ] bi
211 [ permute-slots ] [ first ] bi
214 : outdated-tuple? ( tuple assoc -- ? )
215 [ [ layout-of ] dip key? ]
216 [ drop class-of "forgotten" word-prop not ]
219 : update-tuples ( -- )
221 dup assoc-empty? [ drop ] [
222 [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
223 dup [ update-tuple ] map become
226 : update-tuples-after ( class -- )
227 [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
229 M: tuple-class update-class
232 [ define-tuple-layout ]
233 [ define-tuple-slots ]
234 [ define-tuple-predicate ]
235 [ define-tuple-prototype ]
238 : define-new-tuple-class ( class superclass slots -- )
240 [ drop f f tuple-class define-class ]
241 [ nip "slots" set-word-prop ]
242 [ 2drop update-classes ]
243 [ 2drop f "defining-class" set-word-prop ]
246 : subclasses ( class -- classes )
247 class-usages [ tuple-class? ] filter ;
249 : each-subclass ( class quot -- )
250 [ subclasses ] dip each ; inline
252 : redefine-tuple-class ( class superclass slots -- )
256 [ update-tuples-after ]
257 [ changed-conditionally ]
261 [ define-new-tuple-class ] 3bi ;
263 : tuple-class-unchanged? ( class superclass slots -- ? )
264 [ [ superclass ] [ bootstrap-word ] bi* = ]
265 [ [ "slots" word-prop ] dip = ]
268 : check-superclass ( superclass -- )
269 dup final-class? [ bad-superclass ] when
270 dup class? [ bad-superclass ] unless drop ;
272 GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
274 : thrower-effect ( slots -- effect )
275 [ name>> ] map { "*" } <effect> ;
277 : error-slots ( slots -- slots' )
279 dup string? [ 1array ] when
280 read-only swap remove
284 : reset-final ( class -- )
286 [ f "final" set-word-prop ]
287 [ changed-conditionally ]
293 : define-tuple-class ( class superclass slots -- )
294 over check-superclass
296 (define-tuple-class) ;
298 GENERIC: make-final ( class -- )
300 M: tuple-class make-final
301 [ dup class-usage ?metaclass-changed ]
302 [ t "final" set-word-prop ]
305 M: word (define-tuple-class)
306 define-new-tuple-class ;
308 M: tuple-class (define-tuple-class)
310 3dup tuple-class-unchanged?
311 [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
313 PREDICATE: error-class < tuple-class
314 "error-class" word-prop ;
316 M: error-class reset-class
317 [ call-next-method ] [ "error-class" remove-word-prop ] bi ;
319 : define-error-class ( class superclass slots -- )
321 [ define-tuple-class ]
322 [ 2drop reset-generic ]
323 [ 2drop t "error-class" set-word-prop ]
326 [ dup [ boa throw ] curry ]
327 [ all-slots thrower-effect ]
332 : boa-effect ( class -- effect )
333 [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
335 ERROR: not-a-tuple-class obj ;
337 : check-tuple-class ( class -- class )
338 dup tuple-class? [ not-a-tuple-class ] unless ; inline
340 : define-boa-word ( word class -- )
341 check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi
344 : forget-slot-accessors ( class slots -- )
347 [ reader-word ?lookup-method forget ]
348 [ writer-word ?lookup-method forget ] 2bi
351 M: tuple-class reset-class
353 dup "slots" word-prop forget-slot-accessors
356 [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
360 M: tuple-class metaclass-changed
361 ! Our superclass is no longer a tuple class, redefine with
363 nip tuple over "slots" word-prop define-tuple-class ;
365 M: tuple-class rank-class drop 1 ;
367 M: tuple-class instance?
368 dup echelon-of layout-class-offset tuple-instance? ;
370 M: tuple-class (flatten-class) dup ,, ;
372 M: tuple-class (classes-intersect?)
374 { [ over builtin-class? ] [ drop tuple eq? ] }
375 { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
378 M: tuple clone (clone) ; inline
380 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
382 : tuple-hashcode ( depth obj -- hash )
385 [ class-of hashcode ] [ tuple-size ] bi
386 [ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi
388 swapd array-nth hashcode* >fixnum rot fixnum-bitxor
389 pick fixnum*fast [ [ fixnum+fast ] keep ] dip swap
390 ] 2curry each drop nip 97531 fixnum+fast ; inline
392 M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
395 dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
398 [ "boa-check" word-prop [ call ] when* ]
402 M: tuple-class initial-value* new t ;