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