delegate: fix delegation to tuples with read only slots

diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 4a280ef58432998b1fc5246ee20c6c2c619cd5b3..4d42f71dc03a40407ddcfeac3347fa19c1981ec8 100644 (file)
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -93,6 +93,17 @@ CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
     [ a>> ] [ b>> ] [ c>> ] tri
 ] unit-test
 
+TUPLE: slot-protocol-test-4 { x read-only } ;
+
+TUPLE: slot-protocol-test-5 { a-read-only-slot read-only } ;
+
+CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ;
+
+[ "hey" ] [
+    "hey" slot-protocol-test-5 boa slot-protocol-test-4 boa
+    a-read-only-slot>>
+] unit-test
+
 GENERIC: do-me ( x -- )
 
 M: f do-me drop ;

diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index ebd6a05b482c30025bb246d3c4a17549f516c866..cdd58afc9e360f7745260211d4c639d2755bba5c 100644 (file)
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -4,7 +4,7 @@
 USING: accessors arrays assocs classes.tuple definitions effects generic
 generic.standard hashtables kernel lexer math parser
 generic.parser sequences sets slots words words.symbol fry
-compiler.units ;
+compiler.units make ;
 IN: delegate
 
 ERROR: broadcast-words-must-have-no-outputs group ;
@@ -22,13 +22,16 @@ GENERIC: group-words ( group -- words )
 M: standard-generic group-words
     dup "combination" word-prop #>> 2array 1array ;
 
-: slot-group-words ( slots -- words )
+: slot-words, ( slot-spec -- )
+    [ name>> reader-word 0 2array , ]
     [
-        name>>
-        [ reader-word 0 2array ]
-        [ writer-word 0 2array ] bi
-        2array
-    ] map concat ;
+        dup read-only>> [ drop ] [
+            name>> writer-word 0 2array ,
+        ] if
+    ] bi ;
+
+: slot-group-words ( slots -- words )
+    [ [ slot-words, ] each ] { } make ;
 
 M: tuple-class group-words
     all-slots slot-group-words ;