core/classes/tuple/tuple.factor

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