core/slots/slots.factor

   1 ! Copyright (C) 2005, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays assocs byte-arrays classes
   4 classes.algebra classes.algebra.private classes.maybe
   5 combinators generic generic.standard hashtables kernel
   6 kernel.private make math quotations sequences sequences.private
   7 slots.private strings words ;
   8 IN: slots
   9
  10 TUPLE: slot-spec name offset class initial read-only ;
  11
  12 PREDICATE: reader < word "reader" word-prop ;
  13
  14 PREDICATE: reader-method < method "reading" word-prop >boolean ;
  15
  16 PREDICATE: writer < word "writer" word-prop ;
  17
  18 PREDICATE: writer-method < method "writing" word-prop >boolean ;
  19
  20 : <slot-spec> ( -- slot-spec )
  21     slot-spec new
  22         object bootstrap-word >>class ;
  23
  24 : define-typecheck ( class generic quot props -- )
  25     [ create-method ] 2dip
  26     [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
  27     [ drop define ]
  28     [ 2drop make-inline ]
  29     3tri ;
  30
  31 GENERIC# reader-quot 1 ( class slot-spec -- quot )
  32
  33 M: object reader-quot
  34     nip [
  35         dup offset>> ,
  36         \ slot ,
  37         dup class>> object bootstrap-word eq?
  38         [ drop ] [ class>> 1array , \ declare , ] if
  39     ] [ ] make ;
  40
  41 : reader-word ( name -- word )
  42     ">>" append "accessors" create-word
  43     dup t "reader" set-word-prop ;
  44
  45 : reader-props ( slot-spec -- assoc )
  46     "reading" associate ;
  47
  48 : define-reader-generic ( name -- )
  49     reader-word ( object -- value ) define-simple-generic ;
  50
  51 : define-reader ( class slot-spec -- )
  52     [ nip name>> define-reader-generic ]
  53     [
  54         {
  55             [ drop ]
  56             [ nip name>> reader-word ]
  57             [ reader-quot ]
  58             [ nip reader-props ]
  59         } 2cleave define-typecheck
  60     ] 2bi ;
  61
  62 : writer-word ( name -- word )
  63     "<<" append "accessors" create-word
  64     dup t "writer" set-word-prop ;
  65
  66 ERROR: bad-slot-value value class ;
  67
  68 GENERIC: instance-check-quot ( obj -- quot )
  69
  70 M: class instance-check-quot ( class -- quot )
  71     {
  72         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
  73         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
  74         [ call-next-method ]
  75     } cond ;
  76
  77 M: object instance-check-quot
  78     [
  79         \ dup ,
  80         [ predicate-def % ]
  81         [ [ bad-slot-value ] curry , ] bi
  82         \ unless ,
  83     ] [ ] make ;
  84
  85 GENERIC# writer-quot 1 ( class slot-spec -- quot )
  86
  87 M: object writer-quot
  88     nip
  89     [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
  90     [ offset>> [ set-slot ] curry ]
  91     bi append ;
  92
  93 : writer-props ( slot-spec -- assoc )
  94     "writing" associate ;
  95
  96 : define-writer-generic ( name -- )
  97     writer-word ( value object -- ) define-simple-generic ;
  98
  99 : define-writer ( class slot-spec -- )
 100     [ nip name>> define-writer-generic ] [
 101         {
 102             [ drop ]
 103             [ nip name>> writer-word ]
 104             [ writer-quot ]
 105             [ nip writer-props ]
 106         } 2cleave define-typecheck
 107     ] 2bi ;
 108
 109 : setter-word ( name -- word )
 110     ">>" prepend "accessors" create-word ;
 111
 112 : define-setter ( name -- )
 113     dup setter-word dup deferred? [
 114         [ \ over , swap writer-word , ] [ ] make
 115         ( object value -- object ) define-inline
 116     ] [ 2drop ] if ;
 117
 118 : changer-word ( name -- word )
 119     "change-" prepend "accessors" create-word ;
 120
 121 : define-changer ( name -- )
 122     dup changer-word dup deferred? [
 123         [
 124             \ over ,
 125             over reader-word 1quotation
 126             [ dip call ] curry [ ] like [ dip swap ] curry %
 127             swap setter-word ,
 128         ] [ ] make ( object quot -- object ) define-inline
 129     ] [ 2drop ] if ;
 130
 131 : define-slot-methods ( class slot-spec -- )
 132     [ define-reader ]
 133     [
 134         dup read-only>> [ 2drop ] [
 135             [ name>> define-setter drop ]
 136             [ name>> define-changer drop ]
 137             [ define-writer ]
 138             2tri
 139         ] if
 140     ] 2bi ;
 141
 142 : define-accessors ( class specs -- )
 143     [ define-slot-methods ] with each ;
 144
 145 : define-protocol-slot ( name -- )
 146     {
 147         [ define-reader-generic ]
 148         [ define-writer-generic ]
 149         [ define-setter ]
 150         [ define-changer ]
 151     } cleave ;
 152
 153 DEFER: initial-value
 154
 155 GENERIC: initial-value* ( class -- object ? )
 156
 157 M: class initial-value* drop f f ;
 158
 159 M: maybe initial-value* drop f t ;
 160
 161 ! Default initial value is f, 0, or the default initial value of
 162 ! the smallest class. Special case 0 because float is ostensibly
 163 ! smaller than integer in union{ integer float } because of
 164 ! alphabetical sorting.
 165 M: anonymous-union initial-value*
 166     {
 167         { [ f over instance? ] [ drop f t ] }
 168         { [ 0 over instance? ] [ drop 0 t ] }
 169         [
 170             members>> sort-classes [ initial-value ] { } map>assoc
 171             ?last [ second t ] [ f f ] if*
 172         ]
 173     } cond ;
 174
 175 ! See if any of the initial values fit the intersection class,
 176 ! or else return that none do, and leave it up to the user to
 177 ! provide an initial: value.
 178 M: anonymous-intersection initial-value*
 179     {
 180         { [ f over instance? ] [ drop f t ] }
 181         { [ 0 over instance? ] [ drop 0 t ] }
 182         [
 183             [ ]
 184             [ participants>> sort-classes [ initial-value ] { } map>assoc ]
 185             [ ] tri
 186
 187             [ [ first2 nip ] dip instance? ] curry find swap [
 188                 nip second t
 189             ] [
 190                 2drop f f
 191             ] if
 192         ]
 193     } cond ;
 194
 195 : initial-value ( class -- object ? )
 196     {
 197         { [ dup only-classoid? ] [ dup initial-value* ] }
 198         { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
 199         { [ \ f bootstrap-word over class<= ] [ f t ] }
 200         { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
 201         { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
 202         { [ float bootstrap-word over class<= ] [ 0.0 t ] }
 203         { [ string bootstrap-word over class<= ] [ "" t ] }
 204         { [ array bootstrap-word over class<= ] [ { } t ] }
 205         { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
 206         { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
 207         { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
 208         [ dup initial-value* ]
 209     } cond [ drop ] 2dip ;
 210
 211 GENERIC: make-slot ( desc -- slot-spec )
 212
 213 M: string make-slot
 214     <slot-spec>
 215         swap >>name ;
 216
 217 : peel-off-name ( slot-spec array -- slot-spec array )
 218     [ first >>name ] [ rest ] bi ; inline
 219
 220 : init-slot-class ( slot-spec class -- slot-spec )
 221     [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
 222
 223 : peel-off-class ( slot-spec array -- slot-spec array )
 224     dup empty? [
 225         dup first classoid? [
 226             [ first init-slot-class ]
 227             [ rest ]
 228             bi
 229         ] when
 230     ] unless ;
 231
 232 ERROR: bad-slot-attribute key ;
 233
 234 : peel-off-attributes ( slot-spec array -- slot-spec array )
 235     dup empty? [
 236         unclip {
 237             { initial: [ [ first >>initial ] [ rest ] bi ] }
 238             { read-only [ [ t >>read-only ] dip ] }
 239             [ bad-slot-attribute ]
 240         } case
 241     ] unless ;
 242
 243 ERROR: bad-initial-value name initial-value class ;
 244
 245 : check-initial-value ( slot-spec -- slot-spec )
 246     [ ] [
 247         [ ] [ initial>> ] [ class>> ] tri
 248         2dup instance? [
 249             2drop
 250         ] [
 251             [ name>> ] 2dip bad-initial-value
 252         ] if
 253     ] if-bootstrapping ;
 254
 255 M: array make-slot
 256     <slot-spec>
 257         swap
 258         peel-off-name
 259         peel-off-class
 260         [ dup empty? ] [ peel-off-attributes ] until drop
 261     check-initial-value ;
 262
 263 M: slot-spec make-slot
 264     check-initial-value ;
 265
 266 : make-slots ( slots -- specs )
 267     [ make-slot ] map ;
 268
 269 : finalize-slots ( specs base -- specs )
 270     over length iota [ + ] with map [ >>offset ] 2map ;
 271
 272 : slot-named* ( name specs -- offset spec/f )
 273     [ name>> = ] with find ;
 274
 275 : slot-named ( name specs -- spec/f )
 276     slot-named* nip ;
 277
 278 ! Predefine some slots, because there are change-* words in other vocabs
 279 ! that nondeterministically cause ambiguities when USEd alongside
 280 ! accessors
 281
 282 SLOT: at
 283 SLOT: nth
 284 SLOT: global