core/classes/tuple/tuple.factor

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