From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 5 Sep 2010 01:48:54 +0000 (-0700)
Subject: delegate: fix delegation to tuples with read only slots
X-Git-Tag: 0.97~4465
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=4995d9153e54437bfb273aff8ce8e49e482b0a6e

delegate: fix delegation to tuples with read only slots
---

diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 4a280ef584..4d42f71dc0 100644
--- 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 ebd6a05b48..cdd58afc9e 100644
--- 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 ;