1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors parser generic kernel classes classes.tuple
4 words slots assocs sequences arrays vectors definitions
5 math hashtables sets generalizations namespaces make ;
8 : protocol-words ( protocol -- words )
9 \ protocol-words word-prop ;
11 : protocol-consult ( protocol -- consulters )
12 \ protocol-consult word-prop ;
14 GENERIC: group-words ( group -- words )
16 M: tuple-class group-words
19 [ reader-word 0 2array ]
20 [ writer-word 0 2array ] bi
26 : consult-method ( word class quot -- )
27 [ drop swap first create-method ]
28 [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
31 : change-word-prop ( word prop quot -- )
32 rot props>> swap change-at ; inline
34 : register-protocol ( group class quot -- )
35 rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
37 : define-consult ( group class quot -- )
39 [ [ group-words ] 2dip [ consult-method ] 2curry each ]
43 scan-word scan-word parse-definition define-consult ; parsing
47 : cross-2each ( seq1 seq2 quot -- )
48 [ with each ] 2curry each ; inline
50 : forget-all-methods ( classes words -- )
51 [ first method forget ] cross-2each ;
53 : protocol-users ( protocol -- users )
54 protocol-consult keys ;
56 : lost-words ( protocol wordlist -- lost-words )
57 [ protocol-words ] dip diff ;
59 : forget-old-definitions ( protocol new-wordlist -- )
60 [ drop protocol-users ] [ lost-words ] 2bi
63 : added-words ( protocol wordlist -- added-words )
64 swap protocol-words diff ;
66 : add-new-definitions ( protocol wordlist -- )
67 [ drop protocol-consult >alist ] [ added-words ] 2bi
68 [ swap first2 consult-method ] cross-2each ;
70 : initialize-protocol-props ( protocol wordlist -- )
72 drop \ protocol-consult
73 [ H{ } assoc-like ] change-word-prop
74 ] [ { } like \ protocol-words set-word-prop ] 2bi ;
76 : fill-in-depth ( wordlist -- wordlist' )
77 [ dup word? [ 0 2array ] when ] map ;
79 : define-protocol ( protocol wordlist -- )
81 [ forget-old-definitions ]
82 [ add-new-definitions ]
83 [ initialize-protocol-props ] 2tri ;
88 [ f "inline" set-word-prop ]
89 [ parse-definition define-protocol ] tri ; parsing
91 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
94 [ f forget-old-definitions ] [ call-next-method ] bi ;
96 : show-words ( wordlist' -- wordlist )
97 [ dup second zero? [ first ] when ] map ;
99 M: protocol definition protocol-words show-words ;
101 M: protocol definer drop \ PROTOCOL: \ ; ;
103 M: protocol group-words protocol-words ;