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 ] [ class-of 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 ( outdated-tuples -- )
 232     dup assoc-empty? [ drop ] [
 233         [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
 234         dup [ update-tuple ] map become
 235     ] if ;
 236
 237 : update-tuples-after ( class -- )
 238     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 239
 240 M: tuple-class update-class
 241     {
 242         [ define-boa-check ]
 243         [ define-tuple-layout ]
 244         [ define-tuple-slots ]
 245         [ define-tuple-predicate ]
 246         [ define-tuple-prototype ]
 247     } cleave ;
 248
 249 : define-new-tuple-class ( class superclass slots -- )
 250     [ drop f f tuple-class define-class ]
 251     [ nip "slots" set-word-prop ]
 252     [ 2drop update-classes ] 3tri ;
 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 ;