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

Fix delegate vocab for lookup-method change.

db4
Doug Coleman 2011-10-03 16:42:24 -07:00
parent bf8bf46d16
commit c14f217300
2 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -64,8 +64,8 @@ CONSULT: beta hey value>> 1 - ;
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test
[ f ] [ hey \ two ?lookup-method ] unit-test
[ f ] [ hey \ four ?lookup-method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
@ -79,7 +79,7 @@ CONSULT: beta hey value>> 1 - ;
[ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test
[ f ] [ hey \ one ?lookup-method ] unit-test
TUPLE: slot-protocol-test-1 a b ;
TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
@ -147,7 +147,7 @@ PROTOCOL: silly-protocol do-me ;
DEFER: slot-protocol-test-3
SLOT: y
[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ f ] [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
[ [ ] ] [
"IN: delegate.tests
@ -157,7 +157,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
[ [ ] ] [
"IN: delegate.tests
@ -167,7 +167,7 @@ TUPLE: slot-protocol-test-3 x y ;"
! We now have a real accessor for the y slot; we don't want it to
! get lost
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
! We want to be able to override methods after consultation
[ [ ] ] [

4
basis/delegate/delegate.factor
View File

@ -91,7 +91,7 @@ M: broadcast (consult-method-quot)
\ protocol-consult word-prop delete-at ;
: unconsult-method ( word consultation -- )
[ class>> swap first lookup-method ] keep
[ class>> swap first ?lookup-method ] keep
over [
over "consultation" word-prop eq?
[ forget ] [ drop ] if
@ -124,7 +124,7 @@ M: consultation forget*
<PRIVATE
: forget-all-methods ( classes words -- )
[ first lookup-method forget ] cartesian-each ;
[ first ?lookup-method forget ] cartesian-each ;
: protocol-users ( protocol -- users )
protocol-consult keys ;