core/slots/slots.factor

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