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

delegate: use string word-prop keys.

locals-and-roots
John Benediktsson 2016-04-14 20:19:54 -07:00
parent c68e0f4f3e
commit 1a7547f33a
2 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/delegate/delegate-tests.factor
View File

@ -192,7 +192,7 @@ DEFER: seq-delegate
{ t } [ { t } [
seq-delegate seq-delegate
sequence-protocol \ protocol-consult word-prop sequence-protocol "protocol-consult" word-prop
key? key?
] unit-test ] unit-test
@ -205,7 +205,7 @@ DEFER: seq-delegate
{ f } [ { f } [
seq-delegate seq-delegate
sequence-protocol \ protocol-consult word-prop sequence-protocol "protocol-consult" word-prop
key? key?
] unit-test ] unit-test

16
basis/delegate/delegate.factor
View File

@ -12,10 +12,10 @@ ERROR: broadcast-words-must-have-no-outputs group ;
<PRIVATE <PRIVATE
: protocol-words ( protocol -- words ) : protocol-words ( protocol -- words )
\ protocol-words word-prop ; "protocol-words" word-prop ;
: protocol-consult ( protocol -- consulters ) : protocol-consult ( protocol -- consulters )
\ protocol-consult word-prop ; "protocol-consult" word-prop ;
GENERIC: group-words ( group -- words ) GENERIC: group-words ( group -- words )
@ -43,10 +43,12 @@ M: tuple-class group-words
! Consultation ! Consultation
TUPLE: consultation group class quot loc ; TUPLE: consultation group class quot loc ;
TUPLE: broadcast < consultation ; TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation ) : <consultation> ( group class quot -- consultation )
f consultation boa ; f consultation boa ;
: <broadcast> ( group class quot -- consultation ) : <broadcast> ( group class quot -- consultation )
[ check-broadcast-group ] 2dip f broadcast boa ; [ check-broadcast-group ] 2dip f broadcast boa ;
@ -64,6 +66,7 @@ GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
M: consultation (consult-method-quot) M: consultation (consult-method-quot)
'[ _ call _ execute ] nip ; '[ _ call _ execute ] nip ;
M: broadcast (consult-method-quot) M: broadcast (consult-method-quot)
'[ _ call [ _ execute ] each ] nip ; '[ _ call [ _ execute ] each ] nip ;
@ -81,7 +84,7 @@ M: broadcast (consult-method-quot)
[ [ group>> group-words ] keep ] dip curry each ; inline [ [ group>> group-words ] keep ] dip curry each ; inline
: register-consult ( consultation -- ) : register-consult ( consultation -- )
[ group>> \ protocol-consult ] [ ] [ class>> ] tri [ group>> "protocol-consult" ] [ ] [ class>> ] tri
'[ [ _ _ ] dip ?set-at ] change-word-prop ; '[ [ _ _ ] dip ?set-at ] change-word-prop ;
: consult-methods ( consultation -- ) : consult-methods ( consultation -- )
@ -89,7 +92,7 @@ M: broadcast (consult-method-quot)
: unregister-consult ( consultation -- ) : unregister-consult ( consultation -- )
[ class>> ] [ group>> ] bi [ class>> ] [ group>> ] bi
\ protocol-consult word-prop delete-at ; "protocol-consult" word-prop delete-at ;
: unconsult-method ( word consultation -- ) : unconsult-method ( word consultation -- )
[ class>> swap first ?lookup-method ] keep [ class>> swap first ?lookup-method ] keep
@ -146,9 +149,9 @@ M: consultation forget*
: initialize-protocol-props ( protocol wordlist -- ) : initialize-protocol-props ( protocol wordlist -- )
[ [
drop \ protocol-consult drop "protocol-consult"
[ H{ } assoc-like ] change-word-prop [ H{ } assoc-like ] change-word-prop
] [ { } like \ protocol-words set-word-prop ] 2bi ; ] [ { } like "protocol-words" set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' ) : fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ; [ dup word? [ 0 2array ] when ] map ;
@ -181,7 +184,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget* M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ; [ f forget-old-definitions ] [ call-next-method ] bi ;
M: protocol definition protocol-words show-words ; M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ; M: protocol definer drop \ PROTOCOL: \ ; ;