Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	extra/delegate/delegate-tests.factor
	extra/delegate/delegate.factor

diff --combined extra/delegate/delegate-tests.factor
index 7f633ed4a4dc1012139d8b89251887c6989c7486,5e0abcd5ba5fa58da1948df4b19f69a543513853..6aa015a74da14ccc4a9fe6807c01c0cd94e5e438
--- 1/extra/delegate/delegate-tests.factor
--- 2/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@@ -2,6 -2,11 +2,6 @@@ USING: delegate kernel arrays tools.tes
  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
  
@@@ -25,20 -30,21 +25,19 @@@ GENERIC: bing ( c -- d 
  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
++[ "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

diff --combined extra/delegate/delegate.factor
index 59b298c2425791f93ce4a3531d2f0b0855501985,506d7175b651d9b5e54d3b3e475943126d1582a0..677375a97087342aebda13cb5d20a66ccf052a95
--- 1/extra/delegate/delegate.factor
--- 2/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@@ -1,44 -1,9 +1,44 @@@
  ! 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 hashtables ;
 -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 -- )
@@@ -47,46 -12,36 +47,46 @@@
  : 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> seq-diff ;
++    >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 seq-diff ;
++    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 ;
@@@ -97,4 -52,51 +97,4 @@@ M: protocol definer drop \ PROTOCOL: \ 
  
  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 ;