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