! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard
-classes slots.private combinators ;
+classes slots.private combinators accessors ;
IN: slots
TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
- over define-simple-generic
- >r create-method r> define ;
+ [
+ dup define-simple-generic
+ create-method
+ ] dip define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum prefix define-typecheck ;
: reader-word ( name -- word )
">>" append (( object -- value )) create-accessor ;
-: define-reader ( class slot name -- )
- reader-word object reader-quot define-slot-word ;
+: define-reader ( class slot name decl -- )
+ [ reader-word ] dip reader-quot define-slot-word ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
-: define-writer ( class slot name -- )
- writer-word [ set-slot ] define-slot-word ;
+ERROR: bad-slot-value value object index ;
+
+: writer-quot ( decl -- quot )
+ [
+ dup object bootstrap-word eq?
+ [ drop \ set-slot , ] [
+ \ pick ,
+ "predicate" word-prop %
+ [ [ set-slot ] [ bad-slot-value ] if ] %
+ ] if
+ ] [ ] make ;
+
+: define-writer ( class slot name decl -- )
+ [ writer-word ] dip writer-quot define-slot-word ;
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;
] [ ] make define-inline
] [ 2drop ] if ;
-: define-slot-methods ( class slot name -- )
- dup define-changer
- dup define-setter
- 3dup define-reader
- define-writer ;
+: define-slot-methods ( class slot-spec -- )
+ {
+ [ [ drop ] [ name>> ] bi* define-changer ]
+ [ [ drop ] [ name>> ] bi* define-setter ]
+ [ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ]
+ [ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ]
+ } 2cleave ;
: define-accessors ( class specs -- )
- [
- dup slot-spec-offset swap slot-spec-name
- define-slot-methods
- ] with each ;
+ [ define-slot-methods ] with each ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;