SLOT: now defines the accessor words instead of just deferring them

diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index 4f4a0cadad627f36825507b8074f45259dbcf207..767cec48301c0ac4f1d969b3f5e746af888b1fc7 100644 (file)
--- 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 d4ae60ca9469852b11fbfb09cd2ce79fd1744611..72c79928cb34bb50888f859c5193b23da11045d9 100644 (file)
--- 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 ;