Fix conflict

extra/delegate/delegate-tests.factor

@@ -1,6 +1,12 @@
-USING: delegate kernel arrays tools.test ;
+USING: delegate kernel arrays tools.test words math definitions
+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
 
@@ -9,19 +15,36 @@ 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 ;
 
 CONSULT: baz goodbye goodbye-these ;
 M: hello foo hello-this ;
-M: hello bar dup hello? swap hello-that 2array ;
+M: hello bar hello-test ;
+M: hello whoa >r hello-this r> + ;
 
 GENERIC: bing ( c -- d )
-CONSULT: hello goodbye goodbye-these ;
+PROTOCOL: bee bing ;
-M: hello bing dup hello? swap hello-that 2array ;
+CONSULT: hello goodbye goodbye-those ;
-MIMIC: bing goodbye hello
+M: hello bing hello-test ;
+MIMIC: bee goodbye hello
 
-[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
+[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
-[ { t 0 } ] [ 1 0 <hello> bing ] 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
+[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] 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 { whoa 1 } ;\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,47 +1,102 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs sequences arrays ;
+USING: parser generic kernel classes words slots assocs sequences arrays
+vectors definitions prettyprint combinators.lib math ;
 IN: delegate
 
-: define-protocol ( wordlist protocol -- )
+! Protocols
-    swap { } like "protocol-words" set-word-prop ;
+
+: 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 ;
+
+: fill-in-depth ( wordlist -- wordlist' )
+    [ dup word? [ 0 2array ] when ] map ;
 
 : PROTOCOL:
-    CREATE-WORD dup define-symbol
+    CREATE-WORD
-    parse-definition swap define-protocol ; parsing
+    dup define-symbol
+    dup f "inline" set-word-prop
+    parse-definition fill-in-depth 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 ;
+
+: show-words ( wordlist' -- wordlist )
+    [ dup second zero? [ first ] when ] map ;
+
+M: protocol definition protocol-words show-words ;
+
+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: generic group-words
-    1array ;
-
 M: tuple-class group-words
-    "slots" word-prop 1 tail ! The first slot is the delegate
+    "slot-names" word-prop [
-    ! 1 tail should be removed when the delegate slot is removed
+        [ reader-word ] [ writer-word ] bi
-    dup [ slot-spec-reader ] map
+        2array [ 0 2array ] map
-    swap [ slot-spec-writer ] map append ;
+    ] 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 ;
 
-: define-consult ( class group quot -- )
+: change-word-prop ( word prop quot -- )
-    >r group-words swap r>
+    >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 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 -- )
-    >r >r group-words r> r> [
+    [ drop swap use-protocol ] [
-        pick "methods" word-prop at dup
+        rot group-words -rot
-        [ >r swap create-method 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

extra/io/encodings/utf16/utf16-docs.factor

@@ -23,7 +23,7 @@ HELP: utf16
 { $see-also "encodings-introduction" } ;
 
 HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." }
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
 { $see-also "encodings-introduction" } ;
 
 { utf16 utf16le utf16be utf16n } related-words