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