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 math quotations sequences sequences.private
11 PRIMITIVE: set-slot ( value obj n -- )
12 PRIMITIVE: slot ( obj m -- value )
15 TUPLE: slot-spec name offset class initial read-only ;
17 PREDICATE: reader < word "reader" word-prop ;
19 PREDICATE: reader-method < method "reading" word-prop >boolean ;
21 PREDICATE: writer < word "writer" word-prop ;
23 PREDICATE: writer-method < method "writing" word-prop >boolean ;
25 : <slot-spec> ( -- slot-spec )
27 object bootstrap-word >>class ;
29 : define-typecheck ( class generic quot props -- )
30 [ create-method ] 2dip
31 [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
36 GENERIC#: reader-quot 1 ( class slot-spec -- quot )
39 nip [ offset>> [ slot ] curry ] [ class>> ] bi
40 dup object bootstrap-word eq?
41 [ drop ] [ 1array [ declare ] curry compose ] if ;
43 : reader-word ( name -- word )
44 ">>" append "accessors" create-word
45 dup t "reader" set-word-prop ;
47 : reader-props ( slot-spec -- assoc )
50 : define-reader-generic ( name -- )
51 reader-word ( object -- value ) define-simple-generic ;
53 : define-reader ( class slot-spec -- )
54 [ nip name>> define-reader-generic ]
58 [ nip name>> reader-word ]
61 } 2cleave define-typecheck
64 : writer-word ( name -- word )
65 "<<" append "accessors" create-word
66 dup t "writer" set-word-prop ;
68 ERROR: bad-slot-value value class ;
70 GENERIC: instance-check-quot ( obj -- quot )
72 M: class instance-check-quot
74 { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
75 { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
79 M: object instance-check-quot
80 [ predicate-def [ dup ] prepose ] keep
81 [ bad-slot-value ] curry [ unless ] curry compose ;
83 GENERIC#: writer-quot 1 ( class slot-spec -- quot )
87 [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
88 [ offset>> [ set-slot ] curry ]
91 : writer-props ( slot-spec -- assoc )
94 : define-writer-generic ( name -- )
95 writer-word ( value object -- ) define-simple-generic ;
97 : define-writer ( class slot-spec -- )
98 [ nip name>> define-writer-generic ] [
101 [ nip name>> writer-word ]
104 } 2cleave define-typecheck
107 : setter-word ( name -- word )
108 ">>" prepend "accessors" create-word ;
110 : define-setter ( name -- )
111 dup setter-word dup deferred? [
112 swap writer-word 1quotation [ over ] prepose
113 ( object value -- object ) define-inline
116 : changer-word ( name -- word )
117 "change-" prepend "accessors" create-word ;
119 : define-changer ( name -- )
120 dup changer-word dup deferred? [
121 over reader-word 1quotation
122 [ dip call ] curry [ dip swap ] curry [ over ] prepose
123 rot setter-word 1quotation compose
124 ( object quot -- object ) define-inline
127 : define-slot-methods ( class slot-spec -- )
130 dup read-only>> [ 2drop ] [
131 [ name>> define-setter drop ]
132 [ name>> define-changer drop ]
138 : define-accessors ( class specs -- )
139 [ define-slot-methods ] with each ;
141 : define-protocol-slot ( name -- )
143 [ define-reader-generic ]
144 [ define-writer-generic ]
151 GENERIC: initial-value* ( class -- object ? )
153 M: class initial-value* drop f f ;
155 M: maybe initial-value* drop f t ;
157 ! Default initial value is f, 0, or the default initial value of
158 ! the smallest class. Special case 0 because float is ostensibly
159 ! smaller than integer in union{ integer float } because of
160 ! alphabetical sorting.
161 M: anonymous-union initial-value*
163 { [ f over instance? ] [ drop f t ] }
164 { [ 0 over instance? ] [ drop 0 t ] }
166 members>> sort-classes [ initial-value ] { } map>assoc
167 ?last [ second t ] [ f f ] if*
171 ! See if any of the initial values fit the intersection class,
172 ! or else return that none do, and leave it up to the user to
173 ! provide an initial: value.
174 M: anonymous-intersection initial-value*
176 { [ f over instance? ] [ drop f t ] }
177 { [ 0 over instance? ] [ drop 0 t ] }
180 [ participants>> sort-classes [ initial-value ] { } map>assoc ]
183 [ [ first2 nip ] dip instance? ] curry find swap [
191 : initial-value ( class -- object ? )
193 { [ dup only-classoid? ] [ dup initial-value* ] }
194 { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
195 { [ \ f bootstrap-word over class<= ] [ f t ] }
196 { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
197 { [ \ integer-array-capacity bootstrap-word over class<= ] [ 0 t ] }
198 { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
199 { [ float bootstrap-word over class<= ] [ 0.0 t ] }
200 { [ string bootstrap-word over class<= ] [ "" t ] }
201 { [ array bootstrap-word over class<= ] [ { } t ] }
202 { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
203 { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
204 { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
205 [ dup initial-value* ]
208 GENERIC: make-slot ( desc -- slot-spec )
214 : peel-off-name ( slot-spec array -- slot-spec array )
215 [ first >>name ] [ rest ] bi ; inline
217 : init-slot-class ( slot-spec class -- slot-spec )
218 [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
220 : peel-off-class ( slot-spec array -- slot-spec array )
222 dup first classoid? [
223 [ first init-slot-class ] [ rest ] bi
227 ERROR: bad-slot-attribute key ;
229 : peel-off-attributes ( slot-spec array -- slot-spec array )
232 { initial: [ [ first >>initial ] [ rest ] bi ] }
233 { read-only [ [ t >>read-only ] dip ] }
234 [ bad-slot-attribute ]
238 ERROR: bad-initial-value name initial-value class ;
240 : check-initial-value ( slot-spec -- slot-spec )
242 [ ] [ initial>> ] [ class>> ] tri
246 [ name>> ] 2dip bad-initial-value
255 [ dup empty? ] [ peel-off-attributes ] until drop
256 check-initial-value ;
258 M: slot-spec make-slot
259 check-initial-value ;
261 : make-slots ( slots -- specs )
264 : finalize-slots ( specs base -- specs )
265 over length <iota> [ + ] with map [ >>offset ] 2map ;
267 : slot-named* ( name specs -- offset spec/f )
268 [ name>> = ] with find ;
270 : slot-named ( name specs -- spec/f )