core/slots/slots.factor

   1 ! Copyright (C) 2005, 2010 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 : (instance-check-quot) ( class -- quot )
  68     [
  69         \ dup ,
  70         [ "predicate" word-prop % ]
  71         [ [ bad-slot-value ] curry , ] bi
  72         \ unless ,
  73     ] [ ] make ;
  74
  75 : instance-check-quot ( class -- quot )
  76     {
  77         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
  78         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
  79         { [ dup integer bootstrap-word eq? ] [ drop [ >integer ] ] }
  80         [ (instance-check-quot) ]
  81     } cond ;
  82
  83 GENERIC# writer-quot 1 ( class slot-spec -- quot )
  84
  85 M: object writer-quot
  86     nip
  87     [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
  88     [ offset>> [ set-slot ] curry ]
  89     bi append ;
  90
  91 : writer-props ( slot-spec -- assoc )
  92     "writing" associate ;
  93
  94 : define-writer-generic ( name -- )
  95     writer-word (( value object -- )) define-simple-generic ;
  96
  97 : define-writer ( class slot-spec -- )
  98     [ nip name>> define-writer-generic ] [
  99         {
 100             [ drop ]
 101             [ nip name>> writer-word ]
 102             [ writer-quot ]
 103             [ nip writer-props ]
 104         } 2cleave define-typecheck
 105     ] 2bi ;
 106
 107 : setter-word ( name -- word )
 108     ">>" prepend "accessors" create ;
 109
 110 : define-setter ( name -- )
 111     dup setter-word dup deferred? [
 112         [ \ over , swap writer-word , ] [ ] make
 113         (( object value -- object )) define-inline
 114     ] [ 2drop ] if ;
 115
 116 : changer-word ( name -- word )
 117     "change-" prepend "accessors" create ;
 118
 119 : define-changer ( name -- )
 120     dup changer-word dup deferred? [
 121         [
 122             \ over ,
 123             over reader-word 1quotation
 124             [ dip call ] curry [ ] like [ dip swap ] curry %
 125             swap setter-word ,
 126         ] [ ] make (( object quot -- object )) define-inline
 127     ] [ 2drop ] if ;
 128
 129 : define-slot-methods ( class slot-spec -- )
 130     [ define-reader ]
 131     [
 132         dup read-only>> [ 2drop ] [
 133             [ name>> define-setter drop ]
 134             [ name>> define-changer drop ]
 135             [ define-writer ]
 136             2tri
 137         ] if
 138     ] 2bi ;
 139
 140 : define-accessors ( class specs -- )
 141     [ define-slot-methods ] with each ;
 142
 143 : define-protocol-slot ( name -- )
 144     {
 145         [ define-reader-generic ]
 146         [ define-writer-generic ]
 147         [ define-setter ]
 148         [ define-changer ]
 149     } cleave ;
 150
 151 ERROR: no-initial-value class ;
 152
 153 GENERIC: initial-value* ( class -- object )
 154
 155 M: class initial-value* no-initial-value ;
 156
 157 : initial-value ( class -- object )
 158     {
 159         { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] }
 160         { [ \ f bootstrap-word over class<= ] [ f ] }
 161         { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
 162         { [ float bootstrap-word over class<= ] [ 0.0 ] }
 163         { [ string bootstrap-word over class<= ] [ "" ] }
 164         { [ array bootstrap-word over class<= ] [ { } ] }
 165         { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
 166         { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
 167         { [ quotation bootstrap-word over class<= ] [ [ ] ] }
 168         [ dup initial-value* ]
 169     } cond nip ;
 170
 171 GENERIC: make-slot ( desc -- slot-spec )
 172
 173 M: string make-slot
 174     <slot-spec>
 175         swap >>name ;
 176
 177 : peel-off-name ( slot-spec array -- slot-spec array )
 178     [ first >>name ] [ rest ] bi ; inline
 179
 180 : peel-off-class ( slot-spec array -- slot-spec array )
 181     dup empty? [
 182         dup first class? [
 183             [ first >>class ] [ rest ] bi
 184         ] when
 185     ] unless ;
 186
 187 ERROR: bad-slot-attribute key ;
 188
 189 : peel-off-attributes ( slot-spec array -- slot-spec array )
 190     dup empty? [
 191         unclip {
 192             { initial: [ [ first >>initial ] [ rest ] bi ] }
 193             { read-only [ [ t >>read-only ] dip ] }
 194             [ bad-slot-attribute ]
 195         } case
 196     ] unless ;
 197
 198 ERROR: bad-initial-value name ;
 199
 200 : check-initial-value ( slot-spec -- slot-spec )
 201     dup initial>> [
 202         [ ] [
 203             dup [ initial>> ] [ class>> ] bi instance?
 204             [ name>> bad-initial-value ] unless
 205         ] if-bootstrapping
 206     ] [
 207         dup class>> initial-value >>initial
 208     ] if ;
 209
 210 M: array make-slot
 211     <slot-spec>
 212         swap
 213         peel-off-name
 214         peel-off-class
 215         [ dup empty? ] [ peel-off-attributes ] until drop
 216     check-initial-value ;
 217
 218 M: slot-spec make-slot
 219     check-initial-value ;
 220
 221 : make-slots ( slots -- specs )
 222     [ make-slot ] map ;
 223
 224 : finalize-slots ( specs base -- specs )
 225     over length iota [ + ] with map [ >>offset ] 2map ;
 226
 227 : slot-named* ( name specs -- offset spec/f )
 228     [ name>> = ] with find ;
 229
 230 : slot-named ( name specs -- spec/f )
 231     slot-named* nip ;