Working on delegate

extra/delegate/delegate-tests.factor

@@ -1,4 +1,5 @@
-USING: delegate kernel arrays tools.test words math ;
+USING: delegate kernel arrays tools.test words math definitions
+compiler.units parser generic prettyprint io.streams.string ;
 IN: delegate.tests
 
 DEFER: example
@@ -6,7 +7,6 @@ DEFER: example
 [ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
 [ 2 ] [ \ example "prop" word-prop ] unit-test
 
-
 TUPLE: hello this that ;
 C: <hello> hello
 
@@ -17,17 +17,29 @@ GENERIC: foo ( x -- y )
 GENERIC: bar ( a -- b )
 PROTOCOL: baz foo bar ;
 
+: hello-test ( hello/goodbye -- array )
+    [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
+
 CONSULT: baz goodbye goodbye-these ;
 M: hello foo hello-this ;
-M: hello bar dup hello? swap hello-that 2array ;
+M: hello bar hello-test ;
 
 GENERIC: bing ( c -- d )
-CONSULT: hello goodbye goodbye-these ;
-M: hello bing dup hello? swap hello-that 2array ;
+CONSULT: hello goodbye goodbye-those ;
+M: hello bing hello-test ;
 MIMIC: bing goodbye hello
 
-[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
-[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
+[ 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 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
+[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+
+[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ V{ goodbye } ] [ baz protocol-users ] unit-test
+
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar ;\n" ]
+[ [ baz see ] with-string-writer ] unit-test
+
+! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
+! [ f ] [ goodbye baz method ] unit-test

extra/delegate/delegate.factor

@@ -1,17 +1,50 @@
 ! 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 ;
+vectors definitions prettyprint ;
 IN: delegate
 
-: define-protocol ( wordlist protocol -- )
-    swap { } like "protocol-words" set-word-prop ;
+! Protocols
+
+: cross-2each ( seq1 seq2 quot -- )
+    [ with each ] 2curry each ; inline
+
+: 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 ;
+
+: users-and-words ( protocol -- users words )
+    [ protocol-users ] [ protocol-words ] bi ;
+
+: forget-old-definitions ( protocol new-wordlist -- )
+    >r users-and-words r>
+    seq-diff forget-all-methods ;
+
+: define-protocol ( protocol wordlist -- )
+    2dup forget-old-definitions
+    { } like "protocol-words" set-word-prop ;
 
 : PROTOCOL:
-    CREATE-WORD dup define-symbol
-    parse-definition swap define-protocol ; parsing
+    CREATE-WORD
+    dup define-symbol
+    dup f "inline" set-word-prop
+    parse-definition define-protocol ; parsing
 
-PREDICATE: protocol < word "protocol-words" word-prop ;
+PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
+
+M: protocol forget*
+    [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+
+M: protocol definition protocol-words ;
+
+M: protocol definer drop \ PROTOCOL: \ ; ;
+
+M: protocol synopsis* word-synopsis ; ! Necessary?
 
 GENERIC: group-words ( group -- words )
 
@@ -22,22 +55,23 @@ M: generic group-words
    1array ;
 
 M: tuple-class group-words
-    "slots" word-prop 1 tail ! The first slot is the delegate
-    ! 1 tail should be removed when the delegate slot is removed
-    dup [ slot-spec-reader ] map
-    swap [ slot-spec-writer ] map append ;
+    "slots" word-prop
+    [ [ slot-spec-reader ] map ]
+    [ [ slot-spec-writer ] map ] bi append ;
+
+! Consultation
 
 : define-consult-method ( word class quot -- )
     pick suffix >r swap create-method r> define ;
 
-: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) )
-    >r 3keep r> call ; inline
-
 : change-word-prop ( word prop quot -- )
     >r swap word-props r> change-at ; inline
 
+: add ( item vector/f -- vector )
+    2dup member? [ nip ] [ ?push ] if ;
+
 : declare-consult ( class group -- )
-    "protocol-users" [ ?push ] change-word-prop ;
+    "protocol-users" [ add ] change-word-prop ;
 
 : define-consult ( class group quot -- )
     >r 2dup declare-consult group-words swap r>
@@ -46,10 +80,12 @@ M: tuple-class group-words
 : CONSULT:
     scan-word scan-word parse-definition swapd define-consult ; parsing
 
+! Mimic still needs to be updated
+
 : define-mimic ( group mimicker mimicked -- )
-    >r >r group-words r> r> [
+    rot group-words -rot [
         pick "methods" word-prop at dup
-        [ >r swap create-method r> word-def define ]
+        [ >r swap create-method-in r> word-def define ]
         [ 3drop ] if
     ] 2curry each ;