1 ! Copyright (C) 2007 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: parser generic kernel classes words slots assocs sequences arrays
4 vectors definitions prettyprint combinators.lib math hashtables sets ;
7 : protocol-words ( protocol -- words )
8 \ protocol-words word-prop ;
10 : protocol-consult ( protocol -- consulters )
11 \ protocol-consult word-prop ;
13 GENERIC: group-words ( group -- words )
15 M: tuple-class group-words
16 "slot-names" word-prop [
17 [ reader-word ] [ writer-word ] bi
18 2array [ 0 2array ] map
23 : consult-method ( word class quot -- )
24 [ drop swap first create-method ]
25 [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
27 : change-word-prop ( word prop quot -- )
28 rot word-props swap change-at ; inline
30 : register-protocol ( group class quot -- )
31 rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
33 : define-consult ( group class quot -- )
34 [ register-protocol ] [
36 [ consult-method ] 2curry each
40 scan-word scan-word parse-definition define-consult ; parsing
44 : cross-2each ( seq1 seq2 quot -- )
45 [ with each ] 2curry each ; inline
47 : forget-all-methods ( classes words -- )
48 [ 2array forget ] cross-2each ;
50 : protocol-users ( protocol -- users )
51 protocol-consult keys ;
53 : lost-words ( protocol wordlist -- lost-words )
54 >r protocol-words r> diff ;
56 : forget-old-definitions ( protocol new-wordlist -- )
57 values [ drop protocol-users ] [ lost-words ] 2bi
60 : added-words ( protocol wordlist -- added-words )
61 swap protocol-words diff ;
63 : add-new-definitions ( protocol wordlist -- )
64 dupd added-words >r protocol-consult >alist r>
65 [ first2 consult-method ] cross-2each ;
67 : initialize-protocol-props ( protocol wordlist -- )
68 [ drop H{ } clone \ protocol-consult set-word-prop ]
69 [ { } like \ protocol-words set-word-prop ] 2bi ;
71 : fill-in-depth ( wordlist -- wordlist' )
72 [ dup word? [ 0 2array ] when ] map ;
74 : define-protocol ( protocol wordlist -- )
76 [ forget-old-definitions ]
77 [ add-new-definitions ]
78 [ initialize-protocol-props ] 2tri ;
83 [ f "inline" set-word-prop ]
84 [ parse-definition define-protocol ] tri ; parsing
86 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
89 [ f forget-old-definitions ] [ call-next-method ] bi ;
91 : show-words ( wordlist' -- wordlist )
92 [ dup second zero? [ first ] when ] map ;
94 M: protocol definition protocol-words show-words ;
96 M: protocol definer drop \ PROTOCOL: \ ; ;
98 M: protocol synopsis* word-synopsis ; ! Necessary?
100 M: protocol group-words protocol-words ;