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