1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions hashtables kernel kernel.private math
4 namespaces sequences sequences.private strings vectors words
5 quotations memory combinators generic classes classes.algebra
6 classes.builtin classes.private slots.private slots
7 compiler.units math.private accessors assocs effects ;
10 PREDICATE: tuple-class < class
11 "metaclass" word-prop tuple-class eq? ;
13 M: tuple class 1 slot 2 slot { word } declare ;
15 ERROR: not-a-tuple object ;
17 : check-tuple ( object -- tuple )
18 dup tuple? [ not-a-tuple ] unless ; inline
20 : all-slots ( class -- slots )
21 superclasses [ "slots" word-prop ] map concat ;
23 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
24 all-slots [ read-only>> ] all? ;
28 : tuple-layout ( class -- layout )
31 : layout-of ( tuple -- layout )
32 1 slot { tuple-layout } declare ; inline
34 : tuple-size ( tuple -- size )
35 layout-of size>> ; inline
37 : prepare-tuple>array ( tuple -- n tuple layout )
38 check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
40 : copy-tuple-slots ( n tuple -- array )
41 [ array-nth ] curry map ;
43 : check-slots ( seq class -- seq class )
46 class>> 2dup instance?
47 [ 2drop ] [ bad-slot-value ] if
49 ] if-bootstrapping ; inline
53 : initial-values ( class -- slots )
54 all-slots [ initial>> ] map ;
56 : pad-slots ( slots class -- slots' class )
57 [ initial-values over length tail append ] keep ; inline
59 : tuple>array ( tuple -- array )
61 >r copy-tuple-slots r>
64 : tuple-slots ( tuple -- seq )
65 prepare-tuple>array drop copy-tuple-slots ;
67 GENERIC: slots>tuple ( seq class -- tuple )
69 M: tuple-class slots>tuple
71 tuple-layout <tuple> [
73 [ [ set-array-nth ] curry ]
77 : >tuple ( seq -- tuple )
80 ERROR: bad-superclass class ;
84 : tuple= ( tuple1 tuple2 -- ? )
85 2dup [ layout-of ] bi@ eq? [
87 [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
93 : tuple-instance? ( object class echelon -- ? )
94 #! 4 slot == superclasses>>
98 [ array-nth eq? ] [ 3drop f ] if
99 ] [ 3drop f ] if ; inline
101 : define-tuple-predicate ( class -- )
102 dup dup tuple-layout echelon>>
103 [ tuple-instance? ] 2curry define-predicate ;
105 : superclass-size ( class -- n )
106 superclasses but-last [ "slots" word-prop length ] sigma ;
108 : (instance-check-quot) ( class -- quot )
111 [ "predicate" word-prop % ]
112 [ [ bad-slot-value ] curry , ] bi
116 : (fixnum-check-quot) ( class -- quot )
117 (instance-check-quot) fixnum "coercer" word-prop prepend ;
119 : instance-check-quot ( class -- quot )
121 { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
122 { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
123 { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
124 [ (instance-check-quot) ]
127 : boa-check-quot ( class -- quot )
128 all-slots [ class>> instance-check-quot ] map spread>quot ;
130 : define-boa-check ( class -- )
131 dup boa-check-quot "boa-check" set-word-prop ;
133 : tuple-prototype ( class -- prototype )
134 [ initial-values ] keep
135 over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
137 : define-tuple-prototype ( class -- )
138 dup tuple-prototype "prototype" set-word-prop ;
140 : finalize-tuple-slots ( class slots -- slots )
141 swap superclass-size 2 + finalize-slots ;
143 : define-tuple-slots ( class -- )
144 dup dup "slots" word-prop finalize-tuple-slots
147 : make-tuple-layout ( class -- layout )
149 [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
150 [ superclasses dup length 1- ] tri
153 : define-tuple-layout ( class -- )
154 dup make-tuple-layout "layout" set-word-prop ;
156 : compute-slot-permutation ( new-slots old-slots -- triples )
157 [ [ [ name>> ] map ] bi@ [ index ] curry map ]
158 [ drop [ class>> ] map ]
159 [ drop [ initial>> ] map ]
162 : update-slot ( old-values n class initial -- value )
164 >r >r swap nth dup r> instance? r> swap
166 ] [ >r 3drop r> ] if ;
168 : apply-slot-permutation ( old-values triples -- new-values )
169 [ first3 update-slot ] with map ;
171 : permute-slots ( old-values layout -- new-values )
172 [ class>> all-slots ] [ outdated-tuples get at ] bi
173 compute-slot-permutation
174 apply-slot-permutation ;
176 : update-tuple ( tuple -- newtuple )
177 [ tuple-slots ] [ layout-of ] bi
178 [ permute-slots ] [ class>> ] bi
181 : outdated-tuple? ( tuple assoc -- ? )
183 [ [ layout-of ] dip key? ]
184 [ drop class "forgotten" word-prop not ]
188 : update-tuples ( -- )
190 dup assoc-empty? [ drop ] [
191 [ outdated-tuple? ] curry instances
192 dup [ update-tuple ] map become
195 [ update-tuples ] update-tuples-hook set-global
197 : update-tuples-after ( class -- )
198 [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
200 M: tuple-class update-class
203 [ define-tuple-layout ]
204 [ define-tuple-slots ]
205 [ define-tuple-predicate ]
206 [ define-tuple-prototype ]
209 : define-new-tuple-class ( class superclass slots -- )
211 [ drop f f tuple-class define-class ]
212 [ nip "slots" set-word-prop ]
213 [ 2drop update-classes ]
216 : subclasses ( class -- classes )
217 class-usages [ tuple-class? ] filter ;
219 : each-subclass ( class quot -- )
220 >r subclasses r> each ; inline
222 : redefine-tuple-class ( class superclass slots -- )
226 [ update-tuples-after ]
231 [ define-new-tuple-class ]
234 : tuple-class-unchanged? ( class superclass slots -- ? )
235 rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
237 : valid-superclass? ( class -- ? )
238 [ tuple-class? ] [ tuple eq? ] bi or ;
240 : check-superclass ( superclass -- )
241 dup valid-superclass? [ bad-superclass ] unless drop ;
245 GENERIC# define-tuple-class 2 ( class superclass slots -- )
247 M: word define-tuple-class
248 over check-superclass
249 define-new-tuple-class ;
251 M: tuple-class define-tuple-class
252 over check-superclass
253 3dup tuple-class-unchanged?
254 [ 3drop ] [ redefine-tuple-class ] if ;
256 : thrower-effect ( slots -- effect )
257 [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
259 : define-error-class ( class superclass slots -- )
260 [ define-tuple-class ]
261 [ 2drop reset-generic ]
263 [ dup [ boa throw ] curry ]
269 M: tuple-class reset-class
271 dup "slots" word-prop [
273 [ reader-word method forget ]
274 [ writer-word method forget ] 2bi
278 [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
282 M: tuple-class rank-class drop 0 ;
284 M: tuple-class instance?
285 dup tuple-layout echelon>> tuple-instance? ;
287 M: tuple-class (flatten-class) dup set ;
289 M: tuple-class (classes-intersect?)
291 { [ over tuple eq? ] [ 2drop t ] }
292 { [ over builtin-class? ] [ 2drop f ] }
293 { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
294 [ swap classes-intersect? ]
297 M: tuple clone (clone) ;
299 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
303 [ class hashcode ] [ tuple-size ] [ ] tri
305 swapd array-nth hashcode* sequence-hashcode-step
307 ] recursive-hashcode ;
310 dup "prototype" word-prop
311 [ (clone) ] [ tuple-layout <tuple> ] ?if ;
314 [ "boa-check" word-prop call ]
318 M: tuple-class initial-value* new ;