1 ! Copyright (C) 2005, 2009 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 ;
9 TUPLE: slot-spec name offset class initial read-only ;
11 PREDICATE: reader < word "reader" word-prop ;
13 PREDICATE: reader-method < method-body "reading" word-prop ;
15 PREDICATE: writer < word "writer" word-prop ;
17 PREDICATE: writer-method < method-body "writing" word-prop ;
19 : <slot-spec> ( -- slot-spec )
21 object bootstrap-word >>class ;
23 : define-typecheck ( class generic quot props -- )
24 [ create-method ] 2dip
25 [ [ props>> ] [ drop ] [ ] tri* update ]
30 GENERIC# reader-quot 1 ( class slot-spec -- quot )
36 dup class>> object bootstrap-word eq?
37 [ drop ] [ class>> 1array , \ declare , ] if
40 : reader-word ( name -- word )
41 ">>" append "accessors" create
42 dup t "reader" set-word-prop ;
44 : reader-props ( slot-spec -- assoc )
47 : define-reader-generic ( name -- )
48 reader-word (( object -- value )) define-simple-generic ;
50 : define-reader ( class slot-spec -- )
51 [ nip name>> define-reader-generic ]
55 [ nip name>> reader-word ]
58 } 2cleave define-typecheck
61 : writer-word ( name -- word )
62 "(>>" ")" surround "accessors" create
63 dup t "writer" set-word-prop ;
65 ERROR: bad-slot-value value class ;
67 : writer-quot/object ( slot-spec -- )
68 offset>> , \ set-slot , ;
70 : writer-quot/coerce ( slot-spec -- )
71 [ class>> "coercer" word-prop [ dip ] curry % ]
72 [ offset>> , \ set-slot , ]
75 : writer-quot/check ( slot-spec -- )
79 dup class>> "predicate" word-prop %
81 class>> [ 2nip bad-slot-value ] curry [ ] like ,
86 : writer-quot/fixnum ( slot-spec -- )
87 [ [ >fixnum ] dip ] % writer-quot/check ;
89 GENERIC# writer-quot 1 ( class slot-spec -- quot )
94 { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
95 { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
96 { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
101 : writer-props ( slot-spec -- assoc )
102 "writing" associate ;
104 : define-writer-generic ( name -- )
105 writer-word (( value object -- )) define-simple-generic ;
107 : define-writer ( class slot-spec -- )
108 [ nip name>> define-writer-generic ] [
111 [ nip name>> writer-word ]
114 } 2cleave define-typecheck
117 : setter-word ( name -- word )
118 ">>" prepend "accessors" create ;
120 : define-setter ( name -- )
121 dup setter-word dup deferred? [
122 [ \ over , swap writer-word , ] [ ] make
123 (( object value -- object )) define-inline
126 : changer-word ( name -- word )
127 "change-" prepend "accessors" create ;
129 : define-changer ( name -- )
130 dup changer-word dup deferred? [
133 over reader-word 1quotation
134 [ dip call ] curry [ ] like [ dip swap ] curry %
136 ] [ ] make (( object quot -- object )) define-inline
139 : define-slot-methods ( class slot-spec -- )
142 dup read-only>> [ 2drop ] [
143 [ name>> define-setter drop ]
144 [ name>> define-changer drop ]
150 : define-accessors ( class specs -- )
151 [ define-slot-methods ] with each ;
153 : define-protocol-slot ( name -- )
155 [ define-reader-generic ]
156 [ define-writer-generic ]
161 ERROR: no-initial-value class ;
163 GENERIC: initial-value* ( class -- object )
165 M: class initial-value* no-initial-value ;
167 : initial-value ( class -- object )
169 { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] }
170 { [ \ f bootstrap-word over class<= ] [ f ] }
171 { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
172 { [ float bootstrap-word over class<= ] [ 0.0 ] }
173 { [ string bootstrap-word over class<= ] [ "" ] }
174 { [ array bootstrap-word over class<= ] [ { } ] }
175 { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
176 { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
177 { [ quotation bootstrap-word over class<= ] [ [ ] ] }
178 [ dup initial-value* ]
181 GENERIC: make-slot ( desc -- slot-spec )
187 : peel-off-name ( slot-spec array -- slot-spec array )
188 [ first >>name ] [ rest ] bi ; inline
190 : peel-off-class ( slot-spec array -- slot-spec array )
193 [ first >>class ] [ rest ] bi
197 ERROR: bad-slot-attribute key ;
199 : peel-off-attributes ( slot-spec array -- slot-spec array )
202 { initial: [ [ first >>initial ] [ rest ] bi ] }
203 { read-only [ [ t >>read-only ] dip ] }
204 [ bad-slot-attribute ]
208 ERROR: bad-initial-value name ;
210 : check-initial-value ( slot-spec -- slot-spec )
213 dup [ initial>> ] [ class>> ] bi instance?
214 [ name>> bad-initial-value ] unless
217 dup class>> initial-value >>initial
225 [ dup empty? ] [ peel-off-attributes ] until drop
226 check-initial-value ;
228 M: slot-spec make-slot
229 check-initial-value ;
231 : make-slots ( slots -- specs )
234 : finalize-slots ( specs base -- specs )
235 over length iota [ + ] with map [ >>offset ] 2map ;
237 : slot-named* ( name specs -- offset spec/f )
238 [ name>> = ] with find ;
240 : slot-named ( name specs -- spec/f )