{ define-consult POSTPONE: CONSULT: } related-words
-HELP: define-mimic
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
-{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
-
-HELP: MIMIC:
-{ $syntax "MIMIC: group mimicker mimicked" }
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
-
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
-{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
+{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module"
-"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
+"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: }
-{ $subsection define-consult }
-"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
-{ $subsection POSTPONE: MIMIC: }
-{ $subsection define-mimic } ;
+{ $subsection define-consult } ;
IN: delegate
ABOUT: { "delegate" "intro" }
compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
-DEFER: example
-[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
-[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
-[ 2 ] [ \ example "prop" word-prop ] unit-test
-
TUPLE: hello this that ;
C: <hello> hello
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ;
-MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
-[ V{ goodbye } ] [ baz protocol-users ] unit-test
+[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
+[ H{ } ] [ bee protocol-consult ] unit-test
-! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
-! [ [ baz see ] with-string-writer ] unit-test
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint combinators.lib math sets ;
+vectors definitions prettyprint combinators.lib math hashtables sets ;
IN: delegate
+: protocol-words ( protocol -- words )
+ \ protocol-words word-prop ;
+
+: protocol-consult ( protocol -- consulters )
+ \ protocol-consult word-prop ;
+
+GENERIC: group-words ( group -- words )
+
+M: tuple-class group-words
+ "slot-names" word-prop [
+ [ reader-word ] [ writer-word ] bi
+ 2array [ 0 2array ] map
+ ] map concat ;
+
+! Consultation
+
+: consult-method ( word class quot -- )
+ [ drop swap first create-method ]
+ [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
+
+: change-word-prop ( word prop quot -- )
+ rot word-props swap change-at ; inline
+
+: register-protocol ( group class quot -- )
+ rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
+
+: define-consult ( group class quot -- )
+ [ register-protocol ] [
+ rot group-words -rot
+ [ consult-method ] 2curry each
+ ] 3bi ;
+
+: CONSULT:
+ scan-word scan-word parse-definition define-consult ; parsing
+
! Protocols
: cross-2each ( seq1 seq2 quot -- )
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
-: protocol-words ( protocol -- words )
- "protocol-words" word-prop ;
-
: protocol-users ( protocol -- users )
- "protocol-users" word-prop ;
+ protocol-consult keys ;
-: users-and-words ( protocol -- users words )
- [ protocol-users ] [ protocol-words ] bi ;
+: lost-words ( protocol wordlist -- lost-words )
+ >r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- )
- >r users-and-words r>
- diff forget-all-methods ;
+ values [ drop protocol-users ] [ lost-words ] 2bi
+ forget-all-methods ;
-: define-protocol ( protocol wordlist -- )
- ! 2dup forget-old-definitions
- { } like "protocol-words" set-word-prop ;
+: added-words ( protocol wordlist -- added-words )
+ swap protocol-words diff ;
+
+: add-new-definitions ( protocol wordlist -- )
+ dupd added-words >r protocol-consult >alist r>
+ [ first2 consult-method ] cross-2each ;
+
+: initialize-protocol-props ( protocol wordlist -- )
+ [ drop H{ } clone \ protocol-consult set-word-prop ]
+ [ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
+: define-protocol ( protocol wordlist -- )
+ fill-in-depth
+ [ forget-old-definitions ]
+ [ add-new-definitions ]
+ [ initialize-protocol-props ] 2tri ;
+
: PROTOCOL:
CREATE-WORD
- dup define-symbol
- dup f "inline" set-word-prop
- parse-definition fill-in-depth define-protocol ; parsing
+ [ define-symbol ]
+ [ f "inline" set-word-prop ]
+ [ parse-definition define-protocol ] tri ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
- [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+ [ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
M: protocol synopsis* word-synopsis ; ! Necessary?
-GENERIC: group-words ( group -- words )
-
-M: protocol group-words
- "protocol-words" word-prop ;
-
-M: tuple-class group-words
- "slot-names" word-prop [
- [ reader-word ] [ writer-word ] bi
- 2array [ 0 2array ] map
- ] map concat ;
-
-! Consultation
-
-: define-consult-method ( word class quot -- )
- [ drop swap first create-method ]
- [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
-
-: change-word-prop ( word prop quot -- )
- >r swap word-props r> change-at ; inline
-
-: add ( item vector/f -- vector )
- 2dup member? [ nip ] [ ?push ] if ;
-
-: use-protocol ( class group -- )
- "protocol-users" [ add ] change-word-prop ;
-
-: define-consult ( group class quot -- )
- swapd >r 2dup use-protocol group-words swap r>
- [ define-consult-method ] 2curry each ;
-
-: CONSULT:
- scan-word scan-word parse-definition define-consult ; parsing
-
-! Mimic still needs to be updated
-
-: mimic-method ( mimicker mimicked generic -- )
- tuck method
- [ [ create-method-in ] [ word-def ] bi* define ]
- [ 2drop ] if* ;
-
-: define-mimic ( group mimicker mimicked -- )
- [ drop swap use-protocol ] [
- rot group-words -rot
- [ rot first mimic-method ] 2curry each
- ] 3bi ;
-
-: MIMIC:
- scan-word scan-word scan-word define-mimic ; parsing
+M: protocol group-words protocol-words ;
projects / factor.git / commitdiff