steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

delegate: fix delegation to tuples with read only slots

db4
Slava Pestov 2010-09-04 18:48:54 -07:00
parent 12b63c5957
commit 4995d9153e
2 changed files with 21 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/delegate/delegate-tests.factor
View File

@ -93,6 +93,17 @@ CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
[ a>> ] [ b>> ] [ c>> ] tri [ a>> ] [ b>> ] [ c>> ] tri
] unit-test ] 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 -- ) GENERIC: do-me ( x -- )
M: f do-me drop ; M: f do-me drop ;

17
basis/delegate/delegate.factor
View File

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