core/classes/tuple/tuple.factor

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