1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg
2 ! Portions copyright (C) 2009 Slava Pestov
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs classes.tuple definitions generic
5 generic.standard hashtables kernel lexer math parser
6 generic.parser sequences sets slots words words.symbol fry
12 : protocol-words ( protocol -- words )
13 \ protocol-words word-prop ;
15 : protocol-consult ( protocol -- consulters )
16 \ protocol-consult word-prop ;
18 GENERIC: group-words ( group -- words )
20 M: standard-generic group-words
21 dup "combination" word-prop #>> 2array 1array ;
23 M: tuple-class group-words
26 [ reader-word 0 2array ]
27 [ writer-word 0 2array ] bi
33 TUPLE: consultation group class quot loc ;
35 : <consultation> ( group class quot -- consultation )
38 : create-consult-method ( word consultation -- method )
39 [ class>> swap first create-method dup fake-definition ] keep
40 [ drop ] [ "consultation" set-word-prop ] 2bi ;
42 PREDICATE: consult-method < method "consultation" word-prop ;
44 M: consult-method reset-word
45 [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
47 : consult-method-quot ( quot word -- object )
48 [ second [ [ dip ] curry ] times ] [ first ] bi
49 '[ _ call _ execute ] ;
51 : consult-method ( word consultation -- )
52 [ create-consult-method ]
53 [ quot>> swap consult-method-quot ] 2bi
56 : change-word-prop ( word prop quot -- )
57 [ swap props>> ] dip change-at ; inline
59 : each-generic ( consultation quot -- )
60 [ [ group>> group-words ] keep ] dip curry each ; inline
62 : register-consult ( consultation -- )
63 [ group>> \ protocol-consult ] [ ] [ class>> ] tri
64 '[ [ _ _ ] dip ?set-at ] change-word-prop ;
66 : consult-methods ( consultation -- )
67 [ consult-method ] each-generic ;
69 : unregister-consult ( consultation -- )
70 [ class>> ] [ group>> ] bi
71 \ protocol-consult word-prop delete-at ;
73 : unconsult-method ( word consultation -- )
74 [ class>> swap first method ] keep
76 over "consultation" word-prop eq?
77 [ forget ] [ drop ] if
80 : unconsult-methods ( consultation -- )
81 [ unconsult-method ] each-generic ;
85 : define-consult ( consultation -- )
86 [ register-consult ] [ consult-methods ] bi ;
89 scan-word scan-word parse-definition <consultation>
90 [ save-location ] [ define-consult ] bi ;
92 M: consultation where loc>> ;
94 M: consultation set-where (>>loc) ;
96 M: consultation forget*
97 [ unconsult-methods ] [ unregister-consult ] bi ;
102 : cross-2each ( seq1 seq2 quot -- )
103 [ with each ] 2curry each ; inline
105 : forget-all-methods ( classes words -- )
106 [ first method forget ] cross-2each ;
108 : protocol-users ( protocol -- users )
109 protocol-consult keys ;
111 : lost-words ( protocol wordlist -- lost-words )
112 [ protocol-words ] dip diff ;
114 : forget-old-definitions ( protocol new-wordlist -- )
115 [ drop protocol-users ] [ lost-words ] 2bi
118 : added-words ( protocol wordlist -- added-words )
119 swap protocol-words diff ;
121 : add-new-definitions ( protocol wordlist -- )
122 [ drop protocol-consult values ] [ added-words ] 2bi
123 [ swap consult-method ] cross-2each ;
125 : initialize-protocol-props ( protocol wordlist -- )
127 drop \ protocol-consult
128 [ H{ } assoc-like ] change-word-prop
129 ] [ { } like \ protocol-words set-word-prop ] 2bi ;
131 : fill-in-depth ( wordlist -- wordlist' )
132 [ dup word? [ 0 2array ] when ] map ;
134 : show-words ( wordlist' -- wordlist )
135 [ dup second zero? [ first ] when ] map ;
139 : define-protocol ( protocol wordlist -- )
140 [ drop define-symbol ] [
142 [ forget-old-definitions ]
143 [ add-new-definitions ]
144 [ initialize-protocol-props ] 2tri
148 CREATE-WORD parse-definition define-protocol ;
150 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
153 [ f forget-old-definitions ] [ call-next-method ] bi ;
156 M: protocol definition protocol-words show-words ;
158 M: protocol definer drop \ PROTOCOL: \ ; ;
160 M: protocol group-words protocol-words ;
162 SYNTAX: SLOT-PROTOCOL:
163 CREATE-WORD ";" parse-tokens
164 [ [ reader-word ] [ writer-word ] bi 2array ] map concat