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 compiler.units math.private accessors assocs effects ;
   8 IN: classes.tuple
   9
  10 PREDICATE: tuple-class < class
  11     "metaclass" word-prop tuple-class eq? ;
  12
  13 M: tuple class 1 slot 2 slot { word } declare ;
  14
  15 ERROR: not-a-tuple object ;
  16
  17 : check-tuple ( object -- tuple )
  18     dup tuple? [ not-a-tuple ] unless ; inline
  19
  20 : all-slots ( class -- slots )
  21     superclasses [ "slots" word-prop ] map concat ;
  22
  23 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
  24     all-slots [ read-only>> ] all? ;
  25
  26 <PRIVATE
  27
  28 : tuple-layout ( class -- layout )
  29     "layout" word-prop ;
  30
  31 : layout-of ( tuple -- layout )
  32     1 slot { tuple-layout } declare ; inline
  33
  34 : tuple-size ( tuple -- size )
  35     layout-of size>> ; inline
  36
  37 : prepare-tuple>array ( tuple -- n tuple layout )
  38     check-tuple [ tuple-size ] [ ] [ 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     >r copy-tuple-slots r>
  62     class>> 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
  70     check-slots pad-slots
  71     tuple-layout <tuple> [
  72         [ tuple-size ]
  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 <PRIVATE
  83
  84 : tuple= ( tuple1 tuple2 -- ? )
  85     2dup [ layout-of ] bi@ eq? [
  86         [ drop tuple-size ]
  87         [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
  88         2bi all-integers?
  89     ] [
  90         2drop f
  91     ] if ; inline
  92
  93 : tuple-instance? ( object class echelon -- ? )
  94     #! 4 slot == superclasses>>
  95     rot dup tuple? [
  96         layout-of 4 slot
  97         2dup 1 slot fixnum<
  98         [ array-nth eq? ] [ 3drop f ] if
  99     ] [ 3drop f ] if ; inline
 100
 101 : define-tuple-predicate ( class -- )
 102     dup dup tuple-layout echelon>>
 103     [ tuple-instance? ] 2curry define-predicate ;
 104
 105 : superclass-size ( class -- n )
 106     superclasses but-last [ "slots" word-prop length ] sigma ;
 107
 108 : (instance-check-quot) ( class -- quot )
 109     [
 110         \ dup ,
 111         [ "predicate" word-prop % ]
 112         [ [ bad-slot-value ] curry , ] bi
 113         \ unless ,
 114     ] [ ] make ;
 115
 116 : (fixnum-check-quot) ( class -- quot )
 117     (instance-check-quot) fixnum "coercer" word-prop prepend ;
 118
 119 : instance-check-quot ( class -- quot )
 120     {
 121         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
 122         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
 123         { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
 124         [ (instance-check-quot) ]
 125     } cond ;
 126
 127 : boa-check-quot ( class -- quot )
 128     all-slots [ class>> instance-check-quot ] map spread>quot ;
 129
 130 : define-boa-check ( class -- )
 131     dup boa-check-quot "boa-check" set-word-prop ;
 132
 133 : tuple-prototype ( class -- prototype )
 134     [ initial-values ] keep
 135     over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
 136
 137 : define-tuple-prototype ( class -- )
 138     dup tuple-prototype "prototype" set-word-prop ;
 139
 140 : finalize-tuple-slots ( class slots -- slots )
 141     swap superclass-size 2 + finalize-slots ;
 142
 143 : define-tuple-slots ( class -- )
 144     dup dup "slots" word-prop finalize-tuple-slots
 145     define-accessors ;
 146
 147 : make-tuple-layout ( class -- layout )
 148     [ ]
 149     [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
 150     [ superclasses dup length 1- ] tri
 151     <tuple-layout> ;
 152
 153 : define-tuple-layout ( class -- )
 154     dup make-tuple-layout "layout" set-word-prop ;
 155
 156 : compute-slot-permutation ( new-slots old-slots -- triples )
 157     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
 158     [ drop [ class>> ] map ]
 159     [ drop [ initial>> ] map ]
 160     2tri 3array flip ;
 161
 162 : update-slot ( old-values n class initial -- value )
 163     pick [
 164         >r >r swap nth dup r> instance? r> swap
 165         [ drop ] [ nip ] if
 166     ] [ >r 3drop r> ] if ;
 167
 168 : apply-slot-permutation ( old-values triples -- new-values )
 169     [ first3 update-slot ] with map ;
 170
 171 : permute-slots ( old-values layout -- new-values )
 172     [ class>> all-slots ] [ outdated-tuples get at ] bi
 173     compute-slot-permutation
 174     apply-slot-permutation ;
 175
 176 : update-tuple ( tuple -- newtuple )
 177     [ tuple-slots ] [ layout-of ] bi
 178     [ permute-slots ] [ class>> ] bi
 179     slots>tuple ;
 180
 181 : outdated-tuple? ( tuple assoc -- ? )
 182     over tuple? [
 183         [ [ layout-of ] dip key? ]
 184         [ drop class "forgotten" word-prop not ]
 185         2bi and
 186     ] [ 2drop f ] if ;
 187
 188 : update-tuples ( -- )
 189     outdated-tuples get
 190     dup assoc-empty? [ drop ] [
 191         [ outdated-tuple? ] curry instances
 192         dup [ update-tuple ] map become
 193     ] if ;
 194
 195 [ update-tuples ] update-tuples-hook set-global
 196
 197 : update-tuples-after ( class -- )
 198     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 199
 200 M: tuple-class update-class
 201     {
 202         [ define-boa-check ]
 203         [ define-tuple-layout ]
 204         [ define-tuple-slots ]
 205         [ define-tuple-predicate ]
 206         [ define-tuple-prototype ]
 207     } cleave ;
 208
 209 : define-new-tuple-class ( class superclass slots -- )
 210     make-slots
 211     [ drop f f tuple-class define-class ]
 212     [ nip "slots" set-word-prop ]
 213     [ 2drop update-classes ]
 214     3tri ;
 215
 216 : subclasses ( class -- classes )
 217     class-usages [ tuple-class? ] filter ;
 218
 219 : each-subclass ( class quot -- )
 220     >r subclasses r> each ; inline
 221
 222 : redefine-tuple-class ( class superclass slots -- )
 223     [
 224         2drop
 225         [
 226             [ update-tuples-after ]
 227             [ redefined ]
 228             bi
 229         ] each-subclass
 230     ]
 231     [ define-new-tuple-class ]
 232     3bi ;
 233
 234 : tuple-class-unchanged? ( class superclass slots -- ? )
 235     rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
 236
 237 : valid-superclass? ( class -- ? )
 238     [ tuple-class? ] [ tuple eq? ] bi or ;
 239
 240 : check-superclass ( superclass -- )
 241     dup valid-superclass? [ bad-superclass ] unless drop ;
 242
 243 PRIVATE>
 244
 245 GENERIC# define-tuple-class 2 ( class superclass slots -- )
 246
 247 M: word define-tuple-class
 248     over check-superclass
 249     define-new-tuple-class ;
 250
 251 M: tuple-class define-tuple-class
 252     over check-superclass
 253     3dup tuple-class-unchanged?
 254     [ 3drop ] [ redefine-tuple-class ] if ;
 255
 256 : thrower-effect ( slots -- effect )
 257     [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
 258
 259 : define-error-class ( class superclass slots -- )
 260     [ define-tuple-class ]
 261     [ 2drop reset-generic ]
 262     [
 263         [ dup [ boa throw ] curry ]
 264         [ drop ]
 265         [ thrower-effect ]
 266         tri* define-declared
 267     ] 3tri ;
 268
 269 M: tuple-class reset-class
 270     [
 271         dup "slots" word-prop [
 272             name>>
 273             [ reader-word method forget ]
 274             [ writer-word method forget ] 2bi
 275         ] with each
 276     ] [
 277         [ call-next-method ]
 278         [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
 279         bi
 280     ] bi ;
 281
 282 M: tuple-class rank-class drop 0 ;
 283
 284 M: tuple-class instance?
 285     dup tuple-layout echelon>> tuple-instance? ;
 286
 287 M: tuple-class (flatten-class) dup set ;
 288
 289 M: tuple-class (classes-intersect?)
 290     {
 291         { [ over tuple eq? ] [ 2drop t ] }
 292         { [ over builtin-class? ] [ 2drop f ] }
 293         { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
 294         [ swap classes-intersect? ]
 295     } cond ;
 296
 297 M: tuple clone (clone) ;
 298
 299 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
 300
 301 M: tuple hashcode*
 302     [
 303         [ class hashcode ] [ tuple-size ] [ ] tri
 304         >r rot r> [
 305             swapd array-nth hashcode* sequence-hashcode-step
 306         ] 2curry each
 307     ] recursive-hashcode ;
 308
 309 M: tuple-class new
 310     dup "prototype" word-prop
 311     [ (clone) ] [ tuple-layout <tuple> ] ?if ;
 312
 313 M: tuple-class boa
 314     [ "boa-check" word-prop call ]
 315     [ tuple-layout ]
 316     bi <tuple-boa> ;
 317
 318 M: tuple-class initial-value* new ;