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