From dffbb120a317184358135d2696a5d4b51db9a184 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 00:39:28 -0600
Subject: [PATCH] SLOT: now defines the accessor words instead of just
 deferring them

---
 core/slots/slots-tests.factor | 17 ++++++++++++++++-
 core/slots/slots.factor       | 20 ++++++++++----------
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index 4f4a0cadad..767cec4830 100644
--- a/core/slots/slots-tests.factor
+++ b/core/slots/slots-tests.factor
@@ -1,6 +1,6 @@
 IN: slots.tests
 USING: math accessors slots strings generic.standard kernel
-tools.test generic words parser eval ;
+tools.test generic words parser eval math.functions ;
 
 TUPLE: r/w-test foo ;
 
@@ -34,3 +34,18 @@ TUPLE: hello length ;
 
 [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
 [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
+
+! Test protocol slots
+SLOT: my-protocol-slot-test
+
+TUPLE: protocol-slot-test-tuple x ;
+
+M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ;
+M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
+
+[ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test
+
+[ 4.0 ] [
+    T{ protocol-slot-test-tuple { x 3 } } clone
+    [ 7 + ] change-my-protocol-slot-test x>>
+] unit-test
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index d4ae60ca94..72c79928cb 100644
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -97,16 +97,16 @@ ERROR: bad-slot-value value class ;
 : setter-word ( name -- word )
     ">>" prepend (( object value -- object )) create-accessor ;
 
-: define-setter ( slot-spec -- )
-    name>> dup setter-word dup deferred? [
+: define-setter ( name -- )
+    dup setter-word dup deferred? [
         [ \ over , swap writer-word , ] [ ] make define-inline
     ] [ 2drop ] if ;
 
 : changer-word ( name -- word )
     "change-" prepend (( object quot -- object )) create-accessor ;
 
-: define-changer ( slot-spec -- )
-    name>> dup changer-word dup deferred? [
+: define-changer ( name -- )
+    dup changer-word dup deferred? [
         [
             [ over >r >r ] %
             over reader-word ,
@@ -119,8 +119,8 @@ ERROR: bad-slot-value value class ;
     [ define-reader ]
     [
         dup read-only>> [ 2drop ] [
-            [ define-setter drop ]
-            [ define-changer drop ]
+            [ name>> define-setter drop ]
+            [ name>> define-changer drop ]
             [ define-writer ]
             2tri
         ] if
@@ -131,10 +131,10 @@ ERROR: bad-slot-value value class ;
 
 : define-protocol-slot ( name -- )
     {
-        [ reader-word drop ]
-        [ writer-word drop ]
-        [ setter-word drop ]
-        [ changer-word drop ]
+        [ reader-word define-simple-generic ]
+        [ writer-word define-simple-generic ]
+        [ define-setter ]
+        [ define-changer ]
     } cleave ;
 
 ERROR: no-initial-value class ;