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     f like ;
 130
 131 : define-boa-check ( class -- )
 132     dup boa-check-quot "boa-check" set-word-prop ;
 133
 134 : tuple-prototype ( class -- prototype )
 135     [ initial-values ] keep
 136     over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
 137
 138 : define-tuple-prototype ( class -- )
 139     dup tuple-prototype "prototype" set-word-prop ;
 140
 141 : finalize-tuple-slots ( class slots -- slots )
 142     swap superclass-size 2 + finalize-slots ;
 143
 144 : define-tuple-slots ( class -- )
 145     dup dup "slots" word-prop finalize-tuple-slots
 146     define-accessors ;
 147
 148 : make-tuple-layout ( class -- layout )
 149     [ ]
 150     [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
 151     [ superclasses dup length 1- ] tri
 152     <tuple-layout> ;
 153
 154 : define-tuple-layout ( class -- )
 155     dup make-tuple-layout "layout" set-word-prop ;
 156
 157 : compute-slot-permutation ( new-slots old-slots -- triples )
 158     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
 159     [ drop [ class>> ] map ]
 160     [ drop [ initial>> ] map ]
 161     2tri 3array flip ;
 162
 163 : update-slot ( old-values n class initial -- value )
 164     pick [
 165         >r >r swap nth dup r> instance? r> swap
 166         [ drop ] [ nip ] if
 167     ] [ >r 3drop r> ] if ;
 168
 169 : apply-slot-permutation ( old-values triples -- new-values )
 170     [ first3 update-slot ] with map ;
 171
 172 : permute-slots ( old-values layout -- new-values )
 173     [ class>> all-slots ] [ outdated-tuples get at ] bi
 174     compute-slot-permutation
 175     apply-slot-permutation ;
 176
 177 : update-tuple ( tuple -- newtuple )
 178     [ tuple-slots ] [ layout-of ] bi
 179     [ permute-slots ] [ class>> ] bi
 180     slots>tuple ;
 181
 182 : outdated-tuple? ( tuple assoc -- ? )
 183     over tuple? [
 184         [ [ layout-of ] dip key? ]
 185         [ drop class "forgotten" word-prop not ]
 186         2bi and
 187     ] [ 2drop f ] if ;
 188
 189 : update-tuples ( -- )
 190     outdated-tuples get
 191     dup assoc-empty? [ drop ] [
 192         [ outdated-tuple? ] curry instances
 193         dup [ update-tuple ] map become
 194     ] if ;
 195
 196 [ update-tuples ] update-tuples-hook set-global
 197
 198 : update-tuples-after ( class -- )
 199     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 200
 201 M: tuple-class update-class
 202     {
 203         [ define-boa-check ]
 204         [ define-tuple-layout ]
 205         [ define-tuple-slots ]
 206         [ define-tuple-predicate ]
 207         [ define-tuple-prototype ]
 208     } cleave ;
 209
 210 : define-new-tuple-class ( class superclass slots -- )
 211     make-slots
 212     [ drop f f tuple-class define-class ]
 213     [ nip "slots" set-word-prop ]
 214     [ 2drop update-classes ]
 215     3tri ;
 216
 217 : subclasses ( class -- classes )
 218     class-usages [ tuple-class? ] filter ;
 219
 220 : each-subclass ( class quot -- )
 221     >r subclasses r> each ; inline
 222
 223 : redefine-tuple-class ( class superclass slots -- )
 224     [
 225         2drop
 226         [
 227             [ update-tuples-after ]
 228             [ redefined ]
 229             bi
 230         ] each-subclass
 231     ]
 232     [ define-new-tuple-class ]
 233     3bi ;
 234
 235 : tuple-class-unchanged? ( class superclass slots -- ? )
 236     rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
 237
 238 : valid-superclass? ( class -- ? )
 239     [ tuple-class? ] [ tuple eq? ] bi or ;
 240
 241 : check-superclass ( superclass -- )
 242     dup valid-superclass? [ bad-superclass ] unless drop ;
 243
 244 PRIVATE>
 245
 246 GENERIC# define-tuple-class 2 ( class superclass slots -- )
 247
 248 M: word define-tuple-class
 249     over check-superclass
 250     define-new-tuple-class ;
 251
 252 M: tuple-class define-tuple-class
 253     over check-superclass
 254     3dup tuple-class-unchanged?
 255     [ 3drop ] [ redefine-tuple-class ] if ;
 256
 257 : thrower-effect ( slots -- effect )
 258     [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
 259
 260 : define-error-class ( class superclass slots -- )
 261     [ define-tuple-class ]
 262     [ 2drop reset-generic ]
 263     [
 264         [ dup [ boa throw ] curry ]
 265         [ drop ]
 266         [ thrower-effect ]
 267         tri* define-declared
 268     ] 3tri ;
 269
 270 M: tuple-class reset-class
 271     [
 272         dup "slots" word-prop [
 273             name>>
 274             [ reader-word method forget ]
 275             [ writer-word method forget ] 2bi
 276         ] with each
 277     ] [
 278         [ call-next-method ]
 279         [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
 280         bi
 281     ] bi ;
 282
 283 M: tuple-class rank-class drop 0 ;
 284
 285 M: tuple-class instance?
 286     dup tuple-layout echelon>> tuple-instance? ;
 287
 288 M: tuple-class (flatten-class) dup set ;
 289
 290 M: tuple-class (classes-intersect?)
 291     {
 292         { [ over tuple eq? ] [ 2drop t ] }
 293         { [ over builtin-class? ] [ 2drop f ] }
 294         { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
 295         [ swap classes-intersect? ]
 296     } cond ;
 297
 298 M: tuple clone (clone) ;
 299
 300 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
 301
 302 M: tuple hashcode*
 303     [
 304         [ class hashcode ] [ tuple-size ] [ ] tri
 305         >r rot r> [
 306             swapd array-nth hashcode* sequence-hashcode-step
 307         ] 2curry each
 308     ] recursive-hashcode ;
 309
 310 M: tuple-class new
 311     dup "prototype" word-prop
 312     [ (clone) ] [ tuple-layout <tuple> ] ?if ;
 313
 314 M: tuple-class boa
 315     [ "boa-check" word-prop [ call ] when* ]
 316     [ tuple-layout ]
 317     bi <tuple-boa> ;
 318
 319 M: tuple-class initial-value* new ;