core/classes/tuple/tuple.factor

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