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
   4 kernel.private math namespaces sequences sequences.private
   5 strings vectors words quotations memory combinators generic
   6 classes classes.private slots.deprecated slots.private slots
   7 compiler.units math.private accessors assocs ;
   8 IN: classes.tuple
   9
  10 M: tuple class 1 slot 2 slot { word } declare ;
  11
  12 ERROR: no-tuple-class class ;
  13
  14 <PRIVATE
  15
  16 GENERIC: tuple-layout ( object -- layout )
  17
  18 M: tuple-class tuple-layout "layout" word-prop ;
  19
  20 M: tuple tuple-layout 1 slot ;
  21
  22 M: tuple-layout tuple-layout ;
  23
  24 : tuple-size tuple-layout layout-size ; inline
  25
  26 : prepare-tuple>array ( tuple -- n tuple layout )
  27     [ tuple-size ] [ ] [ tuple-layout ] tri ;
  28
  29 : copy-tuple-slots ( n tuple -- array )
  30     [ array-nth ] curry map ;
  31
  32 PRIVATE>
  33
  34 : check-tuple ( class -- )
  35     dup tuple-class?
  36     [ drop ] [ no-tuple-class ] if ;
  37
  38 : tuple>array ( tuple -- array )
  39     prepare-tuple>array
  40     >r copy-tuple-slots r>
  41     layout-class prefix ;
  42
  43 : tuple-slots ( tuple -- seq )
  44     prepare-tuple>array drop copy-tuple-slots ;
  45
  46 : slots>tuple ( tuple class -- array )
  47     tuple-layout <tuple> [
  48         [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
  49     ] keep ;
  50
  51 : >tuple ( tuple -- seq )
  52     unclip slots>tuple ;
  53
  54 : slot-names ( class -- seq )
  55     "slot-names" word-prop
  56     [ dup array? [ second ] when ] map ;
  57
  58 : all-slot-names ( class -- slots )
  59     superclasses [ slot-names ] map concat \ class prefix ;
  60
  61 ERROR: bad-superclass class ;
  62
  63 <PRIVATE
  64
  65 : tuple= ( tuple1 tuple2 -- ? )
  66     2dup [ tuple-layout ] bi@ eq? [
  67         [ drop tuple-size ]
  68         [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
  69         2bi all-integers?
  70     ] [
  71         2drop f
  72     ] if ;
  73
  74 ! Predicate generation. We optimize at the expense of simplicity
  75
  76 : (tuple-predicate-quot) ( class -- quot )
  77     #! 4 slot == layout-superclasses
  78     #! 5 slot == layout-echelon
  79     [
  80         [ 1 slot dup 5 slot ] %
  81         dup tuple-layout layout-echelon ,
  82         [ fixnum>= ] %
  83         [
  84             dup tuple-layout layout-echelon ,
  85             [ swap 4 slot array-nth ] %
  86             literalize ,
  87             [ eq? ] %
  88         ] [ ] make ,
  89         [ drop f ] ,
  90         \ if ,
  91     ] [ ] make ;
  92
  93 : tuple-predicate-quot ( class -- quot )
  94     [
  95         [ dup tuple? ] %
  96         (tuple-predicate-quot) ,
  97         [ drop f ] ,
  98         \ if ,
  99     ] [ ] make ;
 100
 101 : define-tuple-predicate ( class -- )
 102     dup tuple-predicate-quot define-predicate ;
 103
 104 : superclass-size ( class -- n )
 105     superclasses but-last-slice
 106     [ slot-names length ] map sum ;
 107
 108 : generate-tuple-slots ( class slots -- slot-specs )
 109     over superclass-size 2 + simple-slots ;
 110
 111 : define-tuple-slots ( class -- )
 112     dup dup "slot-names" word-prop generate-tuple-slots
 113     [ "slots" set-word-prop ]
 114     [ define-accessors ] ! new
 115     [ define-slots ] ! old
 116     2tri ;
 117
 118 : make-tuple-layout ( class -- layout )
 119     [ ]
 120     [ [ superclass-size ] [ slot-names length ] bi + ]
 121     [ superclasses dup length 1- ] tri
 122     <tuple-layout> ;
 123
 124 : define-tuple-layout ( class -- )
 125     dup make-tuple-layout "layout" set-word-prop ;
 126
 127 : compute-slot-permutation ( class old-slot-names -- permutation )
 128     >r all-slot-names r> [ index ] curry map ;
 129
 130 : apply-slot-permutation ( old-values permutation -- new-values )
 131     [ [ swap ?nth ] [ drop f ] if* ] with map ;
 132
 133 : permute-slots ( old-values -- new-values )
 134     dup first dup outdated-tuples get at
 135     compute-slot-permutation
 136     apply-slot-permutation ;
 137
 138 : change-tuple ( tuple quot -- newtuple )
 139     >r tuple>array r> call >tuple ; inline
 140
 141 : update-tuple ( tuple -- newtuple )
 142     [ permute-slots ] change-tuple ;
 143
 144 : update-tuples ( -- )
 145     outdated-tuples get
 146     dup assoc-empty? [ drop ] [
 147         [ >r class r> key? ] curry instances
 148         dup [ update-tuple ] map become
 149     ] if ;
 150
 151 [ update-tuples ] update-tuples-hook set-global
 152
 153 : update-tuples-after ( class -- )
 154     outdated-tuples get [ all-slot-names ] cache drop ;
 155
 156 M: tuple-class update-class
 157     [ define-tuple-layout ]
 158     [ define-tuple-slots ]
 159     [ define-tuple-predicate ]
 160     tri ;
 161
 162 : define-new-tuple-class ( class superclass slots -- )
 163     [ drop f f tuple-class define-class ]
 164     [ nip "slot-names" set-word-prop ]
 165     [ 2drop update-classes ]
 166     3tri ;
 167
 168 : subclasses ( class -- classes )
 169     class-usages keys [ tuple-class? ] filter ;
 170
 171 : each-subclass ( class quot -- )
 172     >r subclasses r> each ; inline
 173
 174 : redefine-tuple-class ( class superclass slots -- )
 175     [
 176         2drop
 177         [
 178             [ update-tuples-after ]
 179             [ +inlined+ changed-definition ]
 180             [ redefined ]
 181             tri
 182         ] each-subclass
 183     ]
 184     [ define-new-tuple-class ]
 185     3bi ;
 186
 187 : tuple-class-unchanged? ( class superclass slots -- ? )
 188     rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
 189
 190 : valid-superclass? ( class -- ? )
 191     [ tuple-class? ] [ tuple eq? ] bi or ;
 192
 193 : check-superclass ( superclass -- )
 194     dup valid-superclass? [ bad-superclass ] unless drop ;
 195
 196 PRIVATE>
 197
 198 GENERIC# define-tuple-class 2 ( class superclass slots -- )
 199
 200 M: word define-tuple-class
 201     over check-superclass
 202     define-new-tuple-class ;
 203
 204 M: tuple-class define-tuple-class
 205     3dup tuple-class-unchanged?
 206     [ over check-superclass 3dup redefine-tuple-class ] unless
 207     3drop ;
 208
 209 : define-error-class ( class superclass slots -- )
 210     [ define-tuple-class ] [ 2drop ] 3bi
 211     dup [ boa throw ] curry define ;
 212
 213 M: tuple-class reset-class
 214     [
 215         dup "slot-names" word-prop [
 216             [ reader-word method forget ]
 217             [ writer-word method forget ] 2bi
 218         ] with each
 219     ] [
 220         {
 221             "class"
 222             "metaclass"
 223             "superclass"
 224             "layout"
 225             "slots"
 226         } reset-props
 227     ] bi ;
 228
 229 M: tuple-class rank-class drop 0 ;
 230
 231 M: tuple clone
 232     (clone) dup delegate clone over set-delegate ;
 233
 234 M: tuple equal?
 235     over tuple? [ tuple= ] [ 2drop f ] if ;
 236
 237 M: tuple hashcode*
 238     [
 239         [ class hashcode ] [ tuple-size ] [ ] tri
 240         >r rot r> [
 241             swapd array-nth hashcode* sequence-hashcode-step
 242         ] 2curry each
 243     ] recursive-hashcode ;
 244
 245 ! Deprecated
 246 M: object get-slots ( obj slots -- ... )
 247     [ execute ] with each ;
 248
 249 M: object set-slots ( ... obj slots -- )
 250     <reversed> get-slots ;
 251
 252 : delegates ( obj -- seq ) [ delegate ] follow ;
 253
 254 : is? ( obj quot -- ? ) >r delegates r> contains? ; inline