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