/core/slots/slots.factor

  1! Copyright (C) 2005, 2011 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors alien arrays assocs byte-arrays classes
  4classes.algebra classes.algebra.private classes.maybe
  5combinators generic generic.standard hashtables kernel
  6kernel.private make math quotations sequences sequences.private
  7slots.private strings words ;
  8IN: slots
  9
 10TUPLE: slot-spec name offset class initial read-only ;
 11
 12PREDICATE: reader < word "reader" word-prop ;
 13
 14PREDICATE: reader-method < method "reading" word-prop >boolean ;
 15
 16PREDICATE: writer < word "writer" word-prop ;
 17
 18PREDICATE: 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
 31GENERIC# reader-quot 1 ( class slot-spec -- quot )
 32
 33M: 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
 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
 64    dup t "writer" set-word-prop ;
 65
 66ERROR: bad-slot-value value class ;
 67
 68GENERIC: instance-check-quot ( obj -- quot )
 69
 70M: 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
 77M: object instance-check-quot
 78    [
 79        \ dup ,
 80        [ predicate-def % ]
 81        [ [ bad-slot-value ] curry , ] bi
 82        \ unless ,
 83    ] [ ] make ;
 84
 85GENERIC# writer-quot 1 ( class slot-spec -- quot )
 86
 87M: 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 ;
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 ;
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
153DEFER: initial-value
154
155GENERIC: initial-value* ( class -- object ? )
156
157M: class initial-value* drop f f ;
158
159M: maybe initial-value*
160    drop f t ;
161
162! Default initial value is f, 0, or the default inital value
163! of the smallest class. Special case 0 because float is ostensibly
164! smaller than integer in union{ integer float } because of
165! alphabetical sorting.
166M: anonymous-union initial-value*
167    {
168        { [ f over instance? ] [ drop f t ] }
169        { [ 0 over instance? ] [ drop 0 t ] }
170        [
171            members>> sort-classes [ initial-value ] { } map>assoc
172            ?last [ second t ] [ f f ] if*
173        ]
174    } cond ;
175
176! See if any of the initial values fit the intersection class,
177! or else return that none do, and leave it up to the user to provide
178! an initial: value.
179M: anonymous-intersection initial-value*
180    {
181        { [ f over instance? ] [ drop f t ] }
182        { [ 0 over instance? ] [ drop 0 t ] }
183        [
184            [ ]
185            [ participants>> sort-classes [ initial-value ] { } map>assoc ]
186            [ ] tri
187
188            [ [ first2 nip ] dip instance? ] curry find swap [
189                nip second t
190            ] [
191                2drop f f
192            ] if
193        ]
194    } cond ;
195
196: initial-value ( class -- object ? )
197    {
198        { [ dup only-classoid? ] [ dup initial-value* ] }
199        { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
200        { [ \ f bootstrap-word over class<= ] [ f t ] }
201        { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
202        { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
203        { [ float bootstrap-word over class<= ] [ 0.0 t ] }
204        { [ string bootstrap-word over class<= ] [ "" t ] }
205        { [ array bootstrap-word over class<= ] [ { } t ] }
206        { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
207        { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
208        { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
209        [ dup initial-value* ]
210    } cond [ drop ] 2dip ;
211
212GENERIC: make-slot ( desc -- slot-spec )
213
214M: string make-slot
215    <slot-spec>
216        swap >>name ;
217
218: peel-off-name ( slot-spec array -- slot-spec array )
219    [ first >>name ] [ rest ] bi ; inline
220
221: init-slot-class ( slot-spec class -- slot-spec )
222    [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
223
224: peel-off-class ( slot-spec array -- slot-spec array )
225    dup empty? [
226        dup first classoid? [
227            [ first init-slot-class ]
228            [ rest ]
229            bi
230        ] when
231    ] unless ;
232
233ERROR: bad-slot-attribute key ;
234
235: peel-off-attributes ( slot-spec array -- slot-spec array )
236    dup empty? [
237        unclip {
238            { initial: [ [ first >>initial ] [ rest ] bi ] }
239            { read-only [ [ t >>read-only ] dip ] }
240            [ bad-slot-attribute ]
241        } case
242    ] unless ;
243
244ERROR: bad-initial-value name initial-value class ;
245
246: check-initial-value ( slot-spec -- slot-spec )
247    [ ] [
248        [ ] [ initial>> ] [ class>> ] tri
249        2dup instance? [
250            2drop
251        ] [
252            [ name>> ] 2dip bad-initial-value
253        ] if
254    ] if-bootstrapping ;
255
256M: array make-slot
257    <slot-spec>
258        swap
259        peel-off-name
260        peel-off-class
261        [ dup empty? ] [ peel-off-attributes ] until drop
262    check-initial-value ;
263
264M: slot-spec make-slot
265    check-initial-value ;
266
267: make-slots ( slots -- specs )
268    [ make-slot ] map ;
269
270: finalize-slots ( specs base -- specs )
271    over length iota [ + ] with map [ >>offset ] 2map ;
272
273: slot-named* ( name specs -- offset spec/f )
274    [ name>> = ] with find ;
275
276: slot-named ( name specs -- spec/f )
277    slot-named* nip ;
278
279! Predefine some slots, because there are change-* words in other vocabs
280! that nondeterministically cause ambiguities when USEd alongside
281! accessors
282
283SLOT: at
284SLOT: nth
285SLOT: global