/core/classes/tuple/tuple.factor

  1! Copyright (C) 2005, 2010 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors arrays assocs classes classes.algebra
  4classes.algebra.private classes.builtin classes.private
  5combinators definitions effects generic kernel kernel.private
  6make math math.private memory namespaces quotations sequences
  7sequences.private slots slots.private strings words ;
  8IN: classes.tuple
  9
 10PREDICATE: tuple-class < class
 11    "metaclass" word-prop tuple-class eq? ;
 12
 13ERROR: not-a-tuple object ;
 14
 15: all-slots ( class -- slots )
 16    superclasses [ "slots" word-prop ] map concat ;
 17
 18ERROR: no-slot name tuple ;
 19
 20: offset-of-slot ( name tuple -- n )
 21    2dup class-of all-slots slot-named
 22    [ 2nip offset>> ] [ no-slot ] if* ;
 23
 24: get-slot-named ( name tuple -- value )
 25    [ nip ] [ offset-of-slot ] 2bi slot ;
 26
 27: set-slot-named ( value name tuple -- )
 28    [ nip ] [ offset-of-slot ] 2bi set-slot ;
 29
 30: set-slots ( assoc tuple -- )
 31    [ swapd set-slot-named ] curry assoc-each ; inline
 32
 33: from-slots ( assoc class -- tuple )
 34    new [ set-slots ] keep ; inline
 35
 36PREDICATE: immutable-tuple-class < tuple-class
 37    all-slots [ read-only>> ] all? ;
 38
 39<PRIVATE
 40
 41: tuple-layout ( class -- layout )
 42    "layout" word-prop ;
 43
 44: layout-of ( tuple -- layout )
 45    1 slot { array } declare ; inline
 46
 47M: tuple class-of layout-of 2 slot { word } declare ; inline
 48
 49: tuple-size ( tuple -- size )
 50    layout-of 3 slot { fixnum } declare ; inline
 51
 52: layout-up-to-date? ( object -- ? )
 53    dup tuple?
 54    [ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
 55
 56: check-tuple ( object -- tuple )
 57    dup tuple? [ not-a-tuple ] unless ; inline
 58
 59: prepare-tuple>array ( tuple -- n tuple layout )
 60    check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
 61
 62: copy-tuple-slots ( n tuple -- array )
 63    [ array-nth ] curry map ;
 64
 65: check-slots ( seq class -- seq class )
 66    [ ] [
 67        2dup all-slots [
 68            class>> 2dup instance?
 69            [ 2drop ] [ bad-slot-value ] if
 70        ] 2each
 71    ] if-bootstrapping ; inline
 72
 73: initial-values ( class -- slots )
 74    all-slots [ initial>> ] map ;
 75
 76: pad-slots ( slots class -- slots' class )
 77    [ initial-values over length tail append ] keep ; inline
 78
 79PRIVATE>
 80
 81: tuple>array ( tuple -- array )
 82    prepare-tuple>array
 83    [ copy-tuple-slots ] dip
 84    first prefix ;
 85
 86: tuple-slots ( tuple -- seq )
 87    prepare-tuple>array drop copy-tuple-slots ;
 88
 89GENERIC: slots>tuple ( seq class -- tuple )
 90
 91M: tuple-class slots>tuple ( seq class -- tuple )
 92    check-slots pad-slots
 93    tuple-layout <tuple> [
 94        [ tuple-size iota ]
 95        [ [ set-array-nth ] curry ]
 96        bi 2each
 97    ] keep ;
 98
 99: >tuple ( seq -- tuple )
100    unclip slots>tuple ;
101
102ERROR: bad-superclass class ;
103
104: tuple= ( tuple1 tuple2 -- ? )
105    2dup [ tuple? ] both? [
106        2dup [ layout-of ] bi@ eq? [
107            [ drop tuple-size ]
108            [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
109            2bi all-integers?
110        ] [ 2drop f ] if
111    ] [ 2drop f ] if ; inline
112
113GENERIC: final-class? ( object -- ? )
114
115M: tuple-class final-class? "final" word-prop ;
116
117M: builtin-class final-class? tuple eq? not ;
118
119M: class final-class? drop t ;
120
121M: object final-class? drop f ;
122
123<PRIVATE
124
125: tuple-predicate-quot/1 ( class -- quot )
126    #! Fast path for tuples with no superclass
127    [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
128    [ dup tuple? ] [ [ drop f ] if ] surround ;
129
130: tuple-instance? ( object class offset -- ? )
131    rot dup tuple? [
132        layout-of
133        2dup 1 slot fixnum<=
134        [ swap slot eq? ] [ 3drop f ] if
135    ] [ 3drop f ] if ; inline
136
137: layout-class-offset ( echelon -- n )
138    2 * 5 + ;
139
140: tuple-predicate-quot ( class echelon -- quot )
141    layout-class-offset [ tuple-instance? ] 2curry ;
142
143: echelon-of ( class -- n )
144    tuple-layout third ;
145
146: define-tuple-predicate ( class -- )
147    dup dup echelon-of {
148        { 1 [ tuple-predicate-quot/1 ] }
149        [ tuple-predicate-quot ]
150    } case define-predicate ;
151
152: class-size ( class -- n )
153    superclasses [ "slots" word-prop length ] map-sum ;
154
155: boa-check-quot ( class -- quot )
156    all-slots [ class>> instance-check-quot ] map shallow-spread>quot
157    f like ;
158
159: define-boa-check ( class -- )
160    dup boa-check-quot "boa-check" set-word-prop ;
161
162: tuple-prototype ( class -- prototype )
163    [ initial-values ] keep over [ ] any?
164    [ slots>tuple ] [ 2drop f ] if ;
165
166: define-tuple-prototype ( class -- )
167    dup tuple-prototype "prototype" set-word-prop ;
168
169: prepare-slots ( slots superclass -- slots' )
170    [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
171
172: define-tuple-slots ( class -- )
173    dup "slots" word-prop over superclass prepare-slots
174    define-accessors ;
175
176: make-tuple-layout ( class -- layout )
177    [
178        {
179            [ , ]
180            [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
181            [ superclasses length 1 - , ]
182            [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
183        } cleave
184    ] { } make ;
185
186: define-tuple-layout ( class -- )
187    dup make-tuple-layout "layout" set-word-prop ;
188
189: compute-slot-permutation ( new-slots old-slots -- triples )
190    [ [ [ name>> ] map ] bi@ [ index ] curry map ]
191    [ drop [ class>> ] map ]
192    [ drop [ initial>> ] map ]
193    2tri 3array flip ;
194
195: update-slot ( old-values n class initial -- value )
196    pick [
197        [ [ swap nth dup ] dip instance? ] dip swap
198        [ drop ] [ nip ] if
199    ] [ [ 3drop ] dip ] if ;
200
201: apply-slot-permutation ( old-values triples -- new-values )
202    [ first3 update-slot ] with map ;
203
204SYMBOL: outdated-tuples
205
206: permute-slots ( old-values layout -- new-values )
207    [ first all-slots ] [ outdated-tuples get at ] bi
208    compute-slot-permutation
209    apply-slot-permutation ;
210
211: update-tuple ( tuple -- newtuple )
212    [ tuple-slots ] [ layout-of ] bi
213    [ permute-slots ] [ first ] bi
214    slots>tuple ;
215
216: outdated-tuple? ( tuple assoc -- ? )
217    [ [ layout-of ] dip key? ]
218    [ drop class-of "forgotten" word-prop not ]
219    2bi and ;
220
221: update-tuples ( -- )
222    outdated-tuples get
223    dup assoc-empty? [ drop ] [
224        [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
225        dup [ update-tuple ] map become
226    ] if ;
227
228: update-tuples-after ( class -- )
229    [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
230
231M: tuple-class update-class
232    {
233        [ define-boa-check ]
234        [ define-tuple-layout ]
235        [ define-tuple-slots ]
236        [ define-tuple-predicate ]
237        [ define-tuple-prototype ]
238    } cleave ;
239
240: define-new-tuple-class ( class superclass slots -- )
241    [ drop f f tuple-class define-class ]
242    [ nip "slots" set-word-prop ]
243    [ 2drop update-classes ]
244    3tri ;
245
246: subclasses ( class -- classes )
247    class-usages [ tuple-class? ] filter ;
248
249: each-subclass ( class quot -- )
250    [ subclasses ] dip each ; inline
251
252: redefine-tuple-class ( class superclass slots -- )
253    [
254        2drop
255        [
256            [ update-tuples-after ]
257            [ changed-conditionally ]
258            bi
259        ] each-subclass
260    ]
261    [ define-new-tuple-class ] 3bi ;
262
263: tuple-class-unchanged? ( class superclass slots -- ? )
264    [ [ superclass ] [ bootstrap-word ] bi* = ]
265    [ [ "slots" word-prop ] dip = ]
266    bi-curry* bi and ;
267
268: check-superclass ( superclass -- )
269    dup final-class? [ bad-superclass ] when
270    dup class? [ bad-superclass ] unless drop ;
271
272GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
273
274: thrower-effect ( slots -- effect )
275    [ name>> ] map { "*" } <effect> ;
276
277: error-slots ( slots -- slots' )
278    [
279        dup string? [ 1array ] when
280        read-only swap remove
281        read-only suffix
282    ] map ;
283
284: reset-final ( class -- )
285    dup final-class? [
286        [ f "final" set-word-prop ]
287        [ changed-conditionally ]
288        bi
289    ] [ drop ] if ;
290
291PRIVATE>
292
293: define-tuple-class ( class superclass slots -- )
294    over check-superclass
295    over prepare-slots
296    (define-tuple-class) ;
297
298GENERIC: make-final ( class -- )
299
300M: tuple-class make-final
301    [ dup class-usage ?metaclass-changed ]
302    [ t "final" set-word-prop ]
303    bi ;
304
305M: word (define-tuple-class)
306    define-new-tuple-class ;
307
308M: tuple-class (define-tuple-class)
309    pick reset-final
310    3dup tuple-class-unchanged?
311    [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
312
313PREDICATE: error-class < tuple-class
314    "error-class" word-prop ;
315
316M: error-class reset-class
317    [ call-next-method ] [ "error-class" remove-word-prop ] bi ;
318
319: define-error-class ( class superclass slots -- )
320    error-slots {
321        [ define-tuple-class ]
322        [ 2drop reset-generic ]
323        [ 2drop t "error-class" set-word-prop ]
324        [
325            2drop
326            [ dup [ boa throw ] curry ]
327            [ all-slots thrower-effect ]
328            bi define-declared
329        ]
330    } 3cleave ;
331
332: boa-effect ( class -- effect )
333    [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
334
335ERROR: not-a-tuple-class obj ;
336
337: check-tuple-class ( class -- class )
338    dup tuple-class? [ not-a-tuple-class ] unless ; inline
339
340: define-boa-word ( word class -- )
341    check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi
342    define-inline ;
343
344: forget-slot-accessors ( class slots -- )
345    [
346        name>>
347        [ reader-word ?lookup-method forget ]
348        [ writer-word ?lookup-method forget ] 2bi
349    ] with each ;
350
351M: tuple-class reset-class
352    [
353        dup "slots" word-prop forget-slot-accessors
354    ] [
355        [ call-next-method ]
356        [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
357        bi
358    ] bi ;
359
360M: tuple-class metaclass-changed
361    ! Our superclass is no longer a tuple class, redefine with
362    ! default superclass
363    nip tuple over "slots" word-prop define-tuple-class ;
364
365M: tuple-class rank-class drop 1 ;
366
367M: tuple-class instance?
368    dup echelon-of layout-class-offset tuple-instance? ;
369
370M: tuple-class (flatten-class) dup ,, ;
371
372M: tuple-class (classes-intersect?)
373    {
374        { [ over builtin-class? ] [ drop tuple eq? ] }
375        { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
376    } cond ;
377
378M: tuple clone (clone) ; inline
379
380M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
381
382: tuple-hashcode ( depth obj -- hash )
383    [
384        [ drop 1000003 ] dip
385        [ class-of hashcode ] [ tuple-size ] bi
386        [ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi
387    ] 2keep [
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
391
392M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
393
394M: tuple-class new
395    dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
396
397M: tuple-class boa
398    [ "boa-check" word-prop [ call ] when* ]
399    [ tuple-layout ]
400    bi <tuple-boa> ;
401
402M: tuple-class initial-value* new t ;