steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

SLOT: now defines the accessor words instead of just deferring them

db4
Slava Pestov 2008-11-14 00:39:28 -06:00
parent 29249e2a64
commit dffbb120a3
2 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
core/slots/slots-tests.factor
View File

@ -1,6 +1,6 @@
IN: slots.tests IN: slots.tests
USING: math accessors slots strings generic.standard kernel USING: math accessors slots strings generic.standard kernel
tools.test generic words parser eval ; tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ; TUPLE: r/w-test foo ;
@ -34,3 +34,18 @@ TUPLE: hello length ;
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! Test protocol slots
SLOT: my-protocol-slot-test
TUPLE: protocol-slot-test-tuple x ;
M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ;
M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
[ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test
[ 4.0 ] [
T{ protocol-slot-test-tuple { x 3 } } clone
[ 7 + ] change-my-protocol-slot-test x>>
] unit-test

20
core/slots/slots.factor
View File

@ -97,16 +97,16 @@ ERROR: bad-slot-value value class ;
: setter-word ( name -- word ) : setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ; ">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( slot-spec -- ) : define-setter ( name -- )
name>> dup setter-word dup deferred? [ dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline [ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ; ] [ 2drop ] if ;
: changer-word ( name -- word ) : changer-word ( name -- word )
"change-" prepend (( object quot -- object )) create-accessor ; "change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( slot-spec -- ) : define-changer ( name -- )
name>> dup changer-word dup deferred? [ dup changer-word dup deferred? [
[ [
[ over >r >r ] % [ over >r >r ] %
over reader-word , over reader-word ,
@ -119,8 +119,8 @@ ERROR: bad-slot-value value class ;
[ define-reader ] [ define-reader ]
[ [
dup read-only>> [ 2drop ] [ dup read-only>> [ 2drop ] [
[ define-setter drop ] [ name>> define-setter drop ]
[ define-changer drop ] [ name>> define-changer drop ]
[ define-writer ] [ define-writer ]
2tri 2tri
] if ] if
@ -131,10 +131,10 @@ ERROR: bad-slot-value value class ;
: define-protocol-slot ( name -- ) : define-protocol-slot ( name -- )
{ {
[ reader-word drop ] [ reader-word define-simple-generic ]
[ writer-word drop ] [ writer-word define-simple-generic ]
[ setter-word drop ] [ define-setter ]
[ changer-word drop ] [ define-changer ]
} cleave ; } cleave ;
ERROR: no-initial-value class ; ERROR: no-initial-value class ;