From 90d4266867eb6af40590f1b05208b1db29aa763a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Thu, 3 Apr 2008 19:17:58 -0500
Subject: [PATCH] Part of delegate changes

---
 extra/delegate/delegate-tests.factor |  8 +++++++-
 extra/delegate/delegate.factor       | 18 ++++++++++++++----
 2 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index d66357daa5..2a0e013c1a 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -1,6 +1,12 @@
-USING: delegate kernel arrays tools.test ;
+USING: delegate kernel arrays tools.test words math ;
 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
 
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 7f24d6258f..8ca99ec565 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,6 +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 ;
+USING: parser generic kernel classes words slots assocs sequences arrays
+vectors ;
 IN: delegate
 
 : define-protocol ( wordlist protocol -- )
@@ -18,7 +19,7 @@ M: protocol group-words
     "protocol-words" word-prop ;
 
 M: generic group-words
-    1array ;
+   1array ;
 
 M: tuple-class group-words
     "slots" word-prop 1 tail ! The first slot is the delegate
@@ -27,10 +28,19 @@ M: tuple-class group-words
     swap [ slot-spec-writer ] map append ;
 
 : define-consult-method ( word class quot -- )
-    pick add >r swap create-method r> define ;
+    pick add >r swap create-method-in 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
+
+: declare-consult ( class group -- )
+    "protocol-users" [ ?push ] change-word-prop ;
 
 : define-consult ( class group quot -- )
-    >r group-words swap r>
+    >r 2dup declare-consult group-words swap r>
     [ define-consult-method ] 2curry each ;
 
 : CONSULT: