More changes to delegate

extra/delegate/delegate-tests.factor

@@ -15,7 +15,8 @@ C: <goodbye> goodbye
 
 GENERIC: foo ( x -- y )
 GENERIC: bar ( a -- b )
-PROTOCOL: baz foo bar ;
+GENERIC# whoa 1 ( s t -- w )
+PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
 
 : hello-test ( hello/goodbye -- array )
     [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
@@ -23,22 +24,26 @@ PROTOCOL: baz foo bar ;
 CONSULT: baz goodbye goodbye-these ;
 M: hello foo hello-this ;
 M: hello bar hello-test ;
+M: hello whoa >r hello-this r> + ;
 
 GENERIC: bing ( c -- d )
+PROTOCOL: bee bing ;
 CONSULT: hello goodbye goodbye-those ;
 M: hello bing hello-test ;
-MIMIC: bing goodbye hello
+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
 
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar ;\n" ]
+[ "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

extra/delegate/delegate.factor

@@ -1,7 +1,7 @@
 ! 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 ;
+vectors definitions prettyprint combinators.lib math ;
 IN: delegate
 
 ! Protocols
@@ -26,21 +26,27 @@ IN: delegate
     seq-diff forget-all-methods ;
 
 : define-protocol ( protocol wordlist -- )
-    2dup forget-old-definitions
+    ! 2dup forget-old-definitions
     { } like "protocol-words" set-word-prop ;
 
+: fill-in-depth ( wordlist -- wordlist' )
+    [ dup word? [ 0 2array ] when ] map ;
+
 : PROTOCOL:
     CREATE-WORD
     dup define-symbol
     dup f "inline" set-word-prop
-    parse-definition define-protocol ; parsing
+    parse-definition fill-in-depth define-protocol ; parsing
 
 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 ;
+: show-words ( wordlist' -- wordlist )
+    [ dup second zero? [ first ] when ] map ;
+
+M: protocol definition protocol-words show-words ;
 
 M: protocol definer drop \ PROTOCOL: \ ; ;
 
@@ -51,18 +57,17 @@ GENERIC: group-words ( group -- words )
 M: protocol group-words
     "protocol-words" word-prop ;
 
-M: generic group-words
-   1array ;
-
 M: tuple-class group-words
-    "slots" word-prop
+    "slot-names" word-prop [
-    [ [ slot-spec-reader ] map ]
+        [ reader-word ] [ writer-word ] bi
-    [ [ slot-spec-writer ] map ] bi append ;
+        2array [ 0 2array ] map
+    ] map concat ;
 
 ! Consultation
 
 : define-consult-method ( word class quot -- )
-    pick suffix >r swap create-method r> define ;
+    [ 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
@@ -70,24 +75,28 @@ M: tuple-class group-words
 : add ( item vector/f -- vector )
     2dup member? [ nip ] [ ?push ] if ;
 
-: declare-consult ( class group -- )
+: use-protocol ( class group -- )
     "protocol-users" [ add ] change-word-prop ;
 
-: define-consult ( class group quot -- )
+: define-consult ( group class quot -- )
-    >r 2dup declare-consult group-words swap r>
+    swapd >r 2dup use-protocol group-words swap r>
     [ define-consult-method ] 2curry each ;
 
 : CONSULT:
-    scan-word scan-word parse-definition swapd define-consult ; parsing
+    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 -- )
-    rot group-words -rot [
+    [ drop swap use-protocol ] [
-        pick "methods" word-prop at dup
+        rot group-words -rot
-        [ >r swap create-method-in r> word-def define ]
+        [ rot first mimic-method ] 2curry each
-        [ 3drop ] if
+    ] 3bi ;
-    ] 2curry each ; 
 
 : MIMIC:
     scan-word scan-word scan-word define-mimic ; parsing

extra/delegate/protocols/protocols.factor

@@ -9,10 +9,8 @@ PROTOCOL: sequence-protocol
     set-nth set-nth-unsafe length set-length lengthen ;
 
 PROTOCOL: assoc-protocol
-    at* assoc-size >alist set-at assoc-clone-like
+    at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
     delete-at clear-assoc new-assoc assoc-like ;
-    ! assoc-find excluded because GENERIC# 1
-    ! everything should work, just slower (with >alist)
 
 PROTOCOL: stream-protocol
     stream-read1 stream-read stream-read-until dispose
@@ -28,5 +26,3 @@ PROTOCOL: prettyprint-section-protocol
     section-fits? indent-section? unindent-first-line?
     newline-after?  short-section? short-section long-section
     <section> delegate>block add-section ;
-
-