Part of delegate changes
parent
053e3e9054
commit
90d4266867
|
@ -1,6 +1,12 @@
|
||||||
USING: delegate kernel arrays tools.test ;
|
USING: delegate kernel arrays tools.test words math ;
|
||||||
IN: delegate.tests
|
IN: delegate.tests
|
||||||
|
|
||||||
|
DEFER: example
|
||||||
|
[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
|
||||||
|
[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
|
||||||
|
[ 2 ] [ \ example "prop" word-prop ] unit-test
|
||||||
|
|
||||||
|
|
||||||
TUPLE: hello this that ;
|
TUPLE: hello this that ;
|
||||||
C: <hello> hello
|
C: <hello> hello
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (C) 2007 Daniel Ehrenberg
|
! Copyright (C) 2007 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser generic kernel classes words slots assocs sequences arrays ;
|
USING: parser generic kernel classes words slots assocs sequences arrays
|
||||||
|
vectors ;
|
||||||
IN: delegate
|
IN: delegate
|
||||||
|
|
||||||
: define-protocol ( wordlist protocol -- )
|
: define-protocol ( wordlist protocol -- )
|
||||||
|
@ -18,7 +19,7 @@ M: protocol group-words
|
||||||
"protocol-words" word-prop ;
|
"protocol-words" word-prop ;
|
||||||
|
|
||||||
M: generic group-words
|
M: generic group-words
|
||||||
1array ;
|
1array ;
|
||||||
|
|
||||||
M: tuple-class group-words
|
M: tuple-class group-words
|
||||||
"slots" word-prop 1 tail ! The first slot is the delegate
|
"slots" word-prop 1 tail ! The first slot is the delegate
|
||||||
|
@ -27,10 +28,19 @@ M: tuple-class group-words
|
||||||
swap [ slot-spec-writer ] map append ;
|
swap [ slot-spec-writer ] map append ;
|
||||||
|
|
||||||
: define-consult-method ( word class quot -- )
|
: define-consult-method ( word class quot -- )
|
||||||
pick add >r swap create-method r> define ;
|
pick add >r swap create-method-in r> define ;
|
||||||
|
|
||||||
|
: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) )
|
||||||
|
>r 3keep r> call ; inline
|
||||||
|
|
||||||
|
: change-word-prop ( word prop quot -- )
|
||||||
|
>r swap word-props r> change-at ; inline
|
||||||
|
|
||||||
|
: declare-consult ( class group -- )
|
||||||
|
"protocol-users" [ ?push ] change-word-prop ;
|
||||||
|
|
||||||
: define-consult ( class group quot -- )
|
: define-consult ( class group quot -- )
|
||||||
>r group-words swap r>
|
>r 2dup declare-consult group-words swap r>
|
||||||
[ define-consult-method ] 2curry each ;
|
[ define-consult-method ] 2curry each ;
|
||||||
|
|
||||||
: CONSULT:
|
: CONSULT:
|
||||||
|
|
Loading…
Reference in New Issue