From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Fri, 18 Apr 2008 04:20:17 +0000 (-0500)
Subject: Merge branch 'master' of git://factorcode.org/git/factor
X-Git-Tag: 0.94~3399^2~5
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=3ac49319695d555ae329f0d6f9f7ba88cd882d2a

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

Conflicts:

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

3ac49319695d555ae329f0d6f9f7ba88cd882d2a
diff --cc extra/delegate/delegate-tests.factor
index 7f633ed4a4,5e0abcd5ba..6aa015a74d
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@@ -34,11 -41,10 +34,10 @@@ M: hello bing hello-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 --cc extra/delegate/delegate.factor
index 59b298c242,506d7175b6..677375a970
--- a/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,26 -12,22 +47,26 @@@
  : 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 ;