<PRIVATE
: protocol-words ( protocol -- words )
- \ protocol-words word-prop ;
+ "protocol-words" word-prop ;
: protocol-consult ( protocol -- consulters )
- \ protocol-consult word-prop ;
+ "protocol-consult" word-prop ;
GENERIC: group-words ( group -- words )
! Consultation
TUPLE: consultation group class quot loc ;
+
TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
f consultation boa ;
+
: <broadcast> ( group class quot -- consultation )
[ check-broadcast-group ] 2dip f broadcast boa ;
M: consultation (consult-method-quot)
'[ _ call _ execute ] nip ;
+
M: broadcast (consult-method-quot)
'[ _ call [ _ execute ] each ] nip ;
[ [ group>> group-words ] keep ] dip curry each ; inline
: register-consult ( consultation -- )
- [ group>> \ protocol-consult ] [ ] [ class>> ] tri
+ [ group>> "protocol-consult" ] [ ] [ class>> ] tri
'[ [ _ _ ] dip ?set-at ] change-word-prop ;
: consult-methods ( consultation -- )
: unregister-consult ( consultation -- )
[ class>> ] [ group>> ] bi
- \ protocol-consult word-prop delete-at ;
+ "protocol-consult" word-prop delete-at ;
: unconsult-method ( word consultation -- )
[ class>> swap first ?lookup-method ] keep
: initialize-protocol-props ( protocol wordlist -- )
[
- drop \ protocol-consult
+ drop "protocol-consult"
[ 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' )
[ dup word? [ 0 2array ] when ] map ;
M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ;
-
M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ;