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