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