1 ! Copyright (C) 2005, 2008 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 words effects generic generic.standard
5 classes classes.algebra slots.private combinators accessors
6 words sequences.private assocs alien ;
9 TUPLE: slot-spec name offset class initial read-only ;
11 PREDICATE: reader < word "reader" word-prop ;
13 PREDICATE: writer < word "writer" word-prop ;
15 : <slot-spec> ( -- slot-spec )
17 object bootstrap-word >>class ;
19 : define-typecheck ( class generic quot props -- )
20 [ dup define-simple-generic create-method ] 2dip
21 [ [ props>> ] [ drop ] [ ] tri* update ]
25 : create-accessor ( name effect -- word )
26 >r "accessors" create dup r>
27 "declared-effect" set-word-prop ;
29 : reader-quot ( slot-spec -- quot )
33 dup class>> object bootstrap-word eq?
34 [ drop ] [ class>> 1array , \ declare , ] if
37 : reader-word ( name -- word )
38 ">>" append (( object -- value )) create-accessor
39 dup t "reader" set-word-prop ;
41 : reader-props ( slot-spec -- assoc )
44 [ read-only>> [ t "foldable" set ] when ] bi
48 : define-reader ( class slot-spec -- )
49 [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
52 : writer-word ( name -- word )
53 "(>>" swap ")" 3append (( value object -- )) create-accessor
54 dup t "writer" set-word-prop ;
56 ERROR: bad-slot-value value class ;
58 : writer-quot/object ( slot-spec -- )
59 offset>> , \ set-slot , ;
61 : writer-quot/coerce ( slot-spec -- )
62 [ \ >r , class>> "coercer" word-prop % \ r> , ]
63 [ offset>> , \ set-slot , ]
66 : writer-quot/check ( slot-spec -- )
70 dup class>> "predicate" word-prop %
72 class>> [ 2nip bad-slot-value ] curry [ ] like ,
77 : writer-quot/fixnum ( slot-spec -- )
78 [ >r >fixnum r> ] % writer-quot/check ;
80 : writer-quot ( slot-spec -- quot )
83 { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
84 { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
85 { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
90 : writer-props ( slot-spec -- assoc )
91 [ "writing" set ] H{ } make-assoc ;
93 : define-writer ( class slot-spec -- )
94 [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
97 : setter-word ( name -- word )
98 ">>" prepend (( object value -- object )) create-accessor ;
100 : define-setter ( slot-spec -- )
101 name>> dup setter-word dup deferred? [
102 [ \ over , swap writer-word , ] [ ] make define-inline
105 : changer-word ( name -- word )
106 "change-" prepend (( object quot -- object )) create-accessor ;
108 : define-changer ( slot-spec -- )
109 name>> dup changer-word dup deferred? [
113 [ r> call r> swap ] %
115 ] [ ] make define-inline
118 : define-slot-methods ( class slot-spec -- )
121 dup read-only>> [ 2drop ] [
122 [ define-setter drop ]
123 [ define-changer drop ]
129 : define-accessors ( class specs -- )
130 [ define-slot-methods ] with each ;
132 : define-protocol-slot ( name -- )
137 [ changer-word drop ]
140 ERROR: no-initial-value class ;
142 GENERIC: initial-value* ( class -- object )
144 M: class initial-value* no-initial-value ;
146 : initial-value ( class -- object )
148 { [ \ f bootstrap-word over class<= ] [ f ] }
149 { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
150 { [ float bootstrap-word over class<= ] [ 0.0 ] }
151 { [ string bootstrap-word over class<= ] [ "" ] }
152 { [ array bootstrap-word over class<= ] [ { } ] }
153 { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
154 { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
155 [ dup initial-value* ]
158 GENERIC: make-slot ( desc -- slot-spec )
164 : peel-off-name ( slot-spec array -- slot-spec array )
165 [ first >>name ] [ rest ] bi ; inline
167 : peel-off-class ( slot-spec array -- slot-spec array )
170 [ first >>class ] [ rest ] bi
174 ERROR: bad-slot-attribute key ;
176 : peel-off-attributes ( slot-spec array -- slot-spec array )
179 { initial: [ [ first >>initial ] [ rest ] bi ] }
180 { read-only [ [ t >>read-only ] dip ] }
181 [ bad-slot-attribute ]
185 ERROR: bad-initial-value name ;
187 : check-initial-value ( slot-spec -- slot-spec )
190 dup [ initial>> ] [ class>> ] bi instance?
191 [ name>> bad-initial-value ] unless
194 dup class>> initial-value >>initial
202 [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
203 check-initial-value ;
205 M: slot-spec make-slot
206 check-initial-value ;
208 : make-slots ( slots -- specs )
211 : finalize-slots ( specs base -- specs )
212 over length [ + ] with map [ >>offset ] 2map ;
214 : slot-named ( name specs -- spec/f )
215 [ name>> = ] with find nip ;