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

Clean up stack shuffling in basis/delegate/

db4
Slava Pestov 2009-01-25 22:57:11 -06:00
parent 6e2f60729f
commit f6bc5c0b75
2 changed files with 6 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -38,7 +38,7 @@ M: hello bing hello-test ;
[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test [ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
GENERIC: one GENERIC: one
M: integer one ; M: integer one ;

9
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions USING: accessors arrays assocs classes.tuple definitions
generalizations generic hashtables kernel lexer make math parser generalizations generic hashtables kernel lexer make math parser
sequences sets slots words words.symbol ; sequences sets slots words words.symbol fry ;
IN: delegate IN: delegate
: protocol-words ( protocol -- words ) : protocol-words ( protocol -- words )
@ -29,14 +29,15 @@ M: tuple-class group-words
define ; define ;
: change-word-prop ( word prop quot -- ) : change-word-prop ( word prop quot -- )
rot props>> swap change-at ; inline [ swap props>> ] dip change-at ; inline
: register-protocol ( group class quot -- ) : register-protocol ( group class quot -- )
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ; [ \ protocol-consult ] 2dip
'[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
: define-consult ( group class quot -- ) : define-consult ( group class quot -- )
[ register-protocol ] [ register-protocol ]
[ [ group-words ] 2dip [ consult-method ] 2curry each ] [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
3bi ; 3bi ;
: CONSULT: : CONSULT: