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 sequences sequences.private strings vectors words
   5 quotations memory combinators generic classes classes.algebra
   6 classes.private slots.deprecated slots.private slots
   7 compiler.units math.private accessors assocs effects ;
   8 IN: classes.tuple
   9
  10 M: tuple class 1 slot 2 slot { word } declare ;
  11
  12 ERROR: not-a-tuple object ;
  13
  14 : check-tuple ( object -- tuple )
  15     dup tuple? [ not-a-tuple ] unless ; inline
  16
  17 <PRIVATE
  18
  19 : (tuple) ( layout -- tuple )
  20     #! In non-optimized code, this word simply calls the
  21     #! <tuple> primitive. In optimized code, an intrinsic
  22     #! is generated which allocates a tuple but does not set
  23     #! any of its slots. This means that any code that uses
  24     #! (tuple) must fill in the slots before the next
  25     #! call to GC.
  26     #!
  27     #! This word is only used in the expansion of <tuple-boa>,
  28     #! where this invariant is guaranteed to hold.
  29     <tuple> ;
  30
  31 : tuple-layout ( class -- layout )
  32     "layout" word-prop ;
  33
  34 : layout-of ( tuple -- layout )
  35     1 slot { tuple-layout } declare ; inline
  36
  37 : tuple-size ( tuple -- size )
  38     layout-of size>> ; inline
  39
  40 : prepare-tuple>array ( tuple -- n tuple layout )
  41     check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
  42
  43 : copy-tuple-slots ( n tuple -- array )
  44     [ array-nth ] curry map ;
  45
  46 PRIVATE>
  47
  48 : tuple>array ( tuple -- array )
  49     prepare-tuple>array
  50     >r copy-tuple-slots r>
  51     class>> prefix ;
  52
  53 : tuple-slots ( tuple -- seq )
  54     prepare-tuple>array drop copy-tuple-slots ;
  55
  56 : all-slots ( class -- slots )
  57     superclasses [ "slots" word-prop ] map concat ;
  58
  59 : check-slots ( seq class -- seq class )
  60     [ ] [
  61         2dup all-slots [
  62             class>> 2dup instance?
  63             [ 2drop ] [ bad-slot-value ] if
  64         ] 2each
  65     ] if-bootstrapping ; inline
  66
  67 GENERIC: slots>tuple ( seq class -- tuple )
  68
  69 M: tuple-class slots>tuple
  70     check-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 : slot-names ( class -- seq )
  81     "slot-names" word-prop ;
  82
  83 ERROR: bad-superclass class ;
  84
  85 <PRIVATE
  86
  87 : tuple= ( tuple1 tuple2 -- ? )
  88     2dup [ layout-of ] bi@ eq? [
  89         [ drop tuple-size ]
  90         [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
  91         2bi all-integers?
  92     ] [
  93         2drop f
  94     ] if ; inline
  95
  96 : tuple-instance? ( object class echelon -- ? )
  97     #! 4 slot == superclasses>>
  98     rot dup tuple? [
  99         layout-of 4 slot
 100         2dup array-capacity fixnum<
 101         [ array-nth eq? ] [ 3drop f ] if
 102     ] [ 3drop f ] if ; inline
 103
 104 : define-tuple-predicate ( class -- )
 105     dup dup tuple-layout echelon>>
 106     [ tuple-instance? ] 2curry define-predicate ;
 107
 108 : superclass-size ( class -- n )
 109     superclasses but-last-slice
 110     [ slot-names length ] map sum ;
 111
 112 : (instance-check-quot) ( class -- quot )
 113     [
 114         \ dup ,
 115         [ "predicate" word-prop % ]
 116         [ [ bad-slot-value ] curry , ] bi
 117         \ unless ,
 118     ] [ ] make ;
 119
 120 : (fixnum-check-quot) ( class -- quot )
 121     (instance-check-quot) fixnum "coercer" word-prop prepend ;
 122
 123 : instance-check-quot ( class -- quot )
 124     {
 125         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
 126         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
 127         { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
 128         [ (instance-check-quot) ]
 129     } cond ;
 130
 131 : boa-check-quot ( class -- quot )
 132     all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
 133
 134 : define-boa-check ( class -- )
 135     dup boa-check-quot "boa-check" set-word-prop ;
 136
 137 : tuple-prototype ( class -- prototype )
 138     [ all-slots [ initial>> ] map ] keep slots>tuple ;
 139
 140 : define-tuple-prototype ( class -- )
 141     dup tuple-prototype "prototype" set-word-prop ;
 142
 143 : generate-tuple-slots ( class slots -- slot-specs )
 144     over superclass-size 2 + make-slots deprecated-slots ;
 145
 146 : define-tuple-slots ( class -- )
 147     dup dup "slot-names" word-prop generate-tuple-slots
 148     [ "slots" set-word-prop ]
 149     [ define-accessors ] ! new
 150     [ define-slots ] ! old
 151     2tri ;
 152
 153 : make-tuple-layout ( class -- layout )
 154     [ ]
 155     [ [ superclass-size ] [ slot-names length ] bi + ]
 156     [ superclasses dup length 1- ] tri
 157     <tuple-layout> ;
 158
 159 : define-tuple-layout ( class -- )
 160     dup make-tuple-layout "layout" set-word-prop ;
 161
 162 : compute-slot-permutation ( new-slots old-slots -- triples )
 163     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
 164     [ drop [ class>> ] map ]
 165     [ drop [ initial>> ] map ]
 166     2tri 3array flip ;
 167
 168 : update-slot ( old-values n class initial -- value )
 169     pick [
 170         >r >r swap nth dup r> instance?
 171         [ r> drop ] [ drop r> ] if
 172     ] [ >r 3drop r> ] if ;
 173
 174 : apply-slot-permutation ( old-values triples -- new-values )
 175     [ first3 update-slot ] with map ;
 176
 177 : permute-slots ( old-values layout -- new-values )
 178     [ class>> all-slots ] [ outdated-tuples get at ] bi
 179     compute-slot-permutation
 180     apply-slot-permutation ;
 181
 182 : update-tuple ( tuple -- newtuple )
 183     [ tuple-slots ] [ layout-of ] bi
 184     [ permute-slots ] [ class>> ] bi
 185     slots>tuple ;
 186
 187 : update-tuples ( -- )
 188     outdated-tuples get
 189     dup assoc-empty? [ drop ] [
 190         [
 191             over tuple?
 192             [ >r layout-of r> key? ] [ 2drop f ] if
 193         ] curry instances
 194         dup [ update-tuple ] map become
 195     ] if ;
 196
 197 [ update-tuples ] update-tuples-hook set-global
 198
 199 : update-tuples-after ( class -- )
 200     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 201
 202 M: tuple-class update-class
 203     {
 204         [ define-tuple-layout ]
 205         [ define-tuple-slots ]
 206         [ define-tuple-predicate ]
 207         [ define-tuple-prototype ]
 208         [ define-boa-check ]
 209     } cleave ;
 210
 211 : define-new-tuple-class ( class superclass slots -- )
 212     [ drop f f tuple-class define-class ]
 213     [ nip "slot-names" 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             [ +inlined+ changed-definition ]
 229             [ redefined ]
 230             tri
 231         ] each-subclass
 232     ]
 233     [ define-new-tuple-class ]
 234     3bi ;
 235
 236 : tuple-class-unchanged? ( class superclass slots -- ? )
 237     rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
 238
 239 : valid-superclass? ( class -- ? )
 240     [ tuple-class? ] [ tuple eq? ] bi or ;
 241
 242 : check-superclass ( superclass -- )
 243     dup valid-superclass? [ bad-superclass ] unless drop ;
 244
 245 PRIVATE>
 246
 247 GENERIC# define-tuple-class 2 ( class superclass slots -- )
 248
 249 M: word define-tuple-class
 250     over check-superclass
 251     define-new-tuple-class ;
 252
 253 M: tuple-class define-tuple-class
 254     over check-superclass
 255     3dup tuple-class-unchanged?
 256     [ 3drop ] [ redefine-tuple-class ] if ;
 257
 258 : thrower-effect ( slots -- effect )
 259     [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
 260
 261 : define-error-class ( class superclass slots -- )
 262     [ define-tuple-class ]
 263     [ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi
 264     define-declared ;
 265
 266 M: tuple-class reset-class
 267     [
 268         dup "slots" word-prop [
 269             name>>
 270             [ reader-word method forget ]
 271             [ writer-word method forget ] 2bi
 272         ] with each
 273     ] [
 274         [ call-next-method ]
 275         [
 276             {
 277                 "layout" "slots" "slot-names" "boa-check" "prototype"
 278             } 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 clone
 288     (clone) dup delegate clone over set-delegate ;
 289
 290 M: tuple equal?
 291     over tuple? [ tuple= ] [ 2drop f ] if ;
 292
 293 M: tuple hashcode*
 294     [
 295         [ class hashcode ] [ tuple-size ] [ ] tri
 296         >r rot r> [
 297             swapd array-nth hashcode* sequence-hashcode-step
 298         ] 2curry each
 299     ] recursive-hashcode ;
 300
 301 M: tuple-class new
 302     "prototype" word-prop (clone) ;
 303
 304 M: tuple-class boa
 305     [ "boa-check" word-prop call ]
 306     [ tuple-layout ]
 307     bi <tuple-boa> ;
 308
 309 ! Deprecated
 310 M: object get-slots ( obj slots -- ... )
 311     [ execute ] with each ;
 312
 313 M: object set-slots ( ... obj slots -- )
 314     <reversed> get-slots ;
 315
 316 : delegates ( obj -- seq ) [ delegate ] follow ;
 317
 318 : is? ( obj quot -- ? ) >r delegates r> contains? ; inline