1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg
2 ! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs classes.tuple definitions effects generic
5 generic.standard hashtables kernel lexer math parser
6 generic.parser sequences sets slots words words.symbol fry
10 ERROR: broadcast-words-must-have-no-outputs group ;
14 : protocol-words ( protocol -- words )
15 \ protocol-words word-prop ;
17 : protocol-consult ( protocol -- consulters )
18 \ protocol-consult word-prop ;
20 GENERIC: group-words ( group -- words )
22 M: standard-generic group-words
23 dup "combination" word-prop #>> 2array 1array ;
25 M: tuple-class group-words
28 [ reader-word 0 2array ]
29 [ writer-word 0 2array ] bi
33 : check-broadcast-group ( group -- group )
34 dup group-words [ first stack-effect out>> empty? ] all?
35 [ broadcast-words-must-have-no-outputs ] unless ;
39 TUPLE: consultation group class quot loc ;
40 TUPLE: broadcast < consultation ;
42 : <consultation> ( group class quot -- consultation )
44 : <broadcast> ( group class quot -- consultation )
45 [ check-broadcast-group ] 2dip f broadcast boa ;
47 : create-consult-method ( word consultation -- method )
48 [ class>> swap first create-method dup fake-definition ] keep
49 [ drop ] [ "consultation" set-word-prop ] 2bi ;
51 PREDICATE: consult-method < method "consultation" word-prop ;
53 M: consult-method reset-word
54 [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
56 GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
58 M: consultation (consult-method-quot)
59 '[ _ call _ execute ] nip ;
60 M: broadcast (consult-method-quot)
61 '[ _ call [ _ execute ] each ] nip ;
63 : consult-method-quot ( consultation word -- object )
65 [ second [ [ dip ] curry ] times ] [ first ] bi
66 (consult-method-quot) ;
68 : consult-method ( word consultation -- )
69 [ create-consult-method ]
70 [ swap consult-method-quot ] 2bi
73 : change-word-prop ( word prop quot -- )
74 [ swap props>> ] dip change-at ; inline
76 : each-generic ( consultation quot -- )
77 [ [ group>> group-words ] keep ] dip curry each ; inline
79 : register-consult ( consultation -- )
80 [ group>> \ protocol-consult ] [ ] [ class>> ] tri
81 '[ [ _ _ ] dip ?set-at ] change-word-prop ;
83 : consult-methods ( consultation -- )
84 [ consult-method ] each-generic ;
86 : unregister-consult ( consultation -- )
87 [ class>> ] [ group>> ] bi
88 \ protocol-consult word-prop delete-at ;
90 : unconsult-method ( word consultation -- )
91 [ class>> swap first method ] keep
93 over "consultation" word-prop eq?
94 [ forget ] [ drop ] if
97 : unconsult-methods ( consultation -- )
98 [ unconsult-method ] each-generic ;
102 : define-consult ( consultation -- )
103 [ register-consult ] [ consult-methods ] bi ;
106 scan-word scan-word parse-definition <consultation>
107 [ save-location ] [ define-consult ] bi ;
110 scan-word scan-word parse-definition <broadcast>
111 [ save-location ] [ define-consult ] bi ;
113 M: consultation where loc>> ;
115 M: consultation set-where (>>loc) ;
117 M: consultation forget*
118 [ unconsult-methods ] [ unregister-consult ] bi ;
123 : forget-all-methods ( classes words -- )
124 [ first method forget ] cartesian-each ;
126 : protocol-users ( protocol -- users )
127 protocol-consult keys ;
129 : lost-words ( protocol wordlist -- lost-words )
130 [ protocol-words ] dip diff ;
132 : forget-old-definitions ( protocol new-wordlist -- )
133 [ drop protocol-users ] [ lost-words ] 2bi
136 : added-words ( protocol wordlist -- added-words )
137 swap protocol-words diff ;
139 : add-new-definitions ( protocol wordlist -- )
140 [ drop protocol-consult values ] [ added-words ] 2bi
141 [ swap consult-method ] cartesian-each ;
143 : initialize-protocol-props ( protocol wordlist -- )
145 drop \ protocol-consult
146 [ H{ } assoc-like ] change-word-prop
147 ] [ { } like \ protocol-words set-word-prop ] 2bi ;
149 : fill-in-depth ( wordlist -- wordlist' )
150 [ dup word? [ 0 2array ] when ] map ;
152 : show-words ( wordlist' -- wordlist )
153 [ dup second zero? [ first ] when ] map ;
157 : define-protocol ( protocol wordlist -- )
158 [ drop define-symbol ] [
160 [ forget-old-definitions ]
161 [ add-new-definitions ]
162 [ initialize-protocol-props ] 2tri
166 CREATE-WORD parse-definition define-protocol ;
168 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
171 [ f forget-old-definitions ] [ call-next-method ] bi ;
174 M: protocol definition protocol-words show-words ;
176 M: protocol definer drop \ PROTOCOL: \ ; ;
178 M: protocol group-words protocol-words ;
180 SYNTAX: SLOT-PROTOCOL:
182 [ [ reader-word ] [ writer-word ] bi 2array ]
183 map-tokens concat define-protocol ;