core/slots/slots.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays byte-arrays kernel kernel.private math namespaces
   4 make sequences strings words effects generic generic.standard
   5 classes classes.algebra slots.private combinators accessors
   6 words sequences.private assocs alien ;
   7 IN: slots
   8
   9 TUPLE: slot-spec name offset class initial read-only ;
  10
  11 PREDICATE: reader < word "reader" word-prop ;
  12
  13 PREDICATE: writer < word "writer" word-prop ;
  14
  15 : <slot-spec> ( -- slot-spec )
  16     slot-spec new
  17         object bootstrap-word >>class ;
  18
  19 : define-typecheck ( class generic quot props -- )
  20     [ dup define-simple-generic create-method ] 2dip
  21     [ [ props>> ] [ drop ] [ ] tri* update ]
  22     [ drop define ]
  23     3bi ;
  24
  25 : create-accessor ( name effect -- word )
  26     >r "accessors" create dup r>
  27     "declared-effect" set-word-prop ;
  28
  29 : reader-quot ( slot-spec -- quot )
  30     [
  31         dup offset>> ,
  32         \ slot ,
  33         dup class>> object bootstrap-word eq?
  34         [ drop ] [ class>> 1array , \ declare , ] if
  35     ] [ ] make ;
  36
  37 : reader-word ( name -- word )
  38     ">>" append (( object -- value )) create-accessor
  39     dup t "reader" set-word-prop ;
  40
  41 : reader-props ( slot-spec -- assoc )
  42     [
  43         [ "reading" set ]
  44         [ read-only>> [ t "foldable" set ] when ] bi
  45         t "flushable" set
  46     ] H{ } make-assoc ;
  47
  48 : define-reader ( class slot-spec -- )
  49     [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
  50     define-typecheck ;
  51
  52 : writer-word ( name -- word )
  53     "(>>" swap ")" 3append (( value object -- )) create-accessor
  54     dup t "writer" set-word-prop ;
  55
  56 ERROR: bad-slot-value value class ;
  57
  58 : writer-quot/object ( slot-spec -- )
  59     offset>> , \ set-slot , ;
  60
  61 : writer-quot/coerce ( slot-spec -- )
  62     [ \ >r , class>> "coercer" word-prop % \ r> , ]
  63     [ offset>> , \ set-slot , ]
  64     bi ;
  65
  66 : writer-quot/check ( slot-spec -- )
  67     [ offset>> , ]
  68     [
  69         \ pick ,
  70         dup class>> "predicate" word-prop %
  71         [ set-slot ] ,
  72         class>> [ 2nip bad-slot-value ] curry [ ] like ,
  73         \ if ,
  74     ]
  75     bi ;
  76
  77 : writer-quot/fixnum ( slot-spec -- )
  78     [ >r >fixnum r> ] % writer-quot/check ;
  79
  80 : writer-quot ( slot-spec -- quot )
  81     [
  82         {
  83             { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
  84             { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
  85             { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
  86             [ writer-quot/check ]
  87         } cond
  88     ] [ ] make ;
  89
  90 : writer-props ( slot-spec -- assoc )
  91     [ "writing" set ] H{ } make-assoc ;
  92
  93 : define-writer ( class slot-spec -- )
  94     [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
  95     define-typecheck ;
  96
  97 : setter-word ( name -- word )
  98     ">>" prepend (( object value -- object )) create-accessor ;
  99
 100 : define-setter ( slot-spec -- )
 101     name>> dup setter-word dup deferred? [
 102         [ \ over , swap writer-word , ] [ ] make define-inline
 103     ] [ 2drop ] if ;
 104
 105 : changer-word ( name -- word )
 106     "change-" prepend (( object quot -- object )) create-accessor ;
 107
 108 : define-changer ( slot-spec -- )
 109     name>> dup changer-word dup deferred? [
 110         [
 111             [ over >r >r ] %
 112             over reader-word ,
 113             [ r> call r> swap ] %
 114             swap setter-word ,
 115         ] [ ] make define-inline
 116     ] [ 2drop ] if ;
 117
 118 : define-slot-methods ( class slot-spec -- )
 119     [ define-reader ]
 120     [
 121         dup read-only>> [ 2drop ] [
 122             [ define-setter drop ]
 123             [ define-changer drop ]
 124             [ define-writer ]
 125             2tri
 126         ] if
 127     ] 2bi ;
 128
 129 : define-accessors ( class specs -- )
 130     [ define-slot-methods ] with each ;
 131
 132 : define-protocol-slot ( name -- )
 133     {
 134         [ reader-word drop ]
 135         [ writer-word drop ]
 136         [ setter-word drop ]
 137         [ changer-word drop ]
 138     } cleave ;
 139
 140 ERROR: no-initial-value class ;
 141
 142 GENERIC: initial-value* ( class -- object )
 143
 144 M: class initial-value* no-initial-value ;
 145
 146 : initial-value ( class -- object )
 147     {
 148         { [ \ f bootstrap-word over class<= ] [ f ] }
 149         { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
 150         { [ float bootstrap-word over class<= ] [ 0.0 ] }
 151         { [ string bootstrap-word over class<= ] [ "" ] }
 152         { [ array bootstrap-word over class<= ] [ { } ] }
 153         { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
 154         { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
 155         [ dup initial-value* ]
 156     } cond nip ;
 157
 158 GENERIC: make-slot ( desc -- slot-spec )
 159
 160 M: string make-slot
 161     <slot-spec>
 162         swap >>name ;
 163
 164 : peel-off-name ( slot-spec array -- slot-spec array )
 165     [ first >>name ] [ rest ] bi ; inline
 166
 167 : peel-off-class ( slot-spec array -- slot-spec array )
 168     dup empty? [
 169         dup first class? [
 170             [ first >>class ] [ rest ] bi
 171         ] when
 172     ] unless ;
 173
 174 ERROR: bad-slot-attribute key ;
 175
 176 : peel-off-attributes ( slot-spec array -- slot-spec array )
 177     dup empty? [
 178         unclip {
 179             { initial: [ [ first >>initial ] [ rest ] bi ] }
 180             { read-only [ [ t >>read-only ] dip ] }
 181             [ bad-slot-attribute ]
 182         } case
 183     ] unless ;
 184
 185 ERROR: bad-initial-value name ;
 186
 187 : check-initial-value ( slot-spec -- slot-spec )
 188     dup initial>> [
 189         [ ] [
 190             dup [ initial>> ] [ class>> ] bi instance?
 191             [ name>> bad-initial-value ] unless
 192         ] if-bootstrapping
 193     ] [
 194         dup class>> initial-value >>initial
 195     ] if ;
 196
 197 M: array make-slot
 198     <slot-spec>
 199         swap
 200         peel-off-name
 201         peel-off-class
 202         [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
 203     check-initial-value ;
 204
 205 M: slot-spec make-slot
 206     check-initial-value ;
 207
 208 : make-slots ( slots -- specs )
 209     [ make-slot ] map ;
 210
 211 : finalize-slots ( specs base -- specs )
 212     over length [ + ] with map [ >>offset ] 2map ;
 213
 214 : slot-named ( name specs -- spec/f )
 215     [ name>> = ] with find nip ;