Fixing delegate reloading

db4
Daniel Ehrenberg 2008-05-10 00:16:46 -05:00
parent b7006bf456
commit b38c9f94dc
3 changed files with 77 additions and 30 deletions

54
extra/delegate/delegate-tests.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string ;
compiler.units parser generic prettyprint io.streams.string
accessors ;
IN: delegate.tests
TUPLE: hello this that ;
@ -16,14 +17,14 @@ PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
: hello-test ( hello/goodbye -- array )
[ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
CONSULT: baz goodbye these>> ;
M: hello foo this>> ;
M: hello bar hello-test ;
M: hello whoa >r hello-this r> + ;
M: hello whoa >r this>> r> + ;
GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
CONSULT: hello goodbye those>> ;
M: hello bing hello-test ;
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
@ -33,11 +34,48 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ H{ { goodbye [ goodbye-these ] } } ] [ baz 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
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
GENERIC: one
M: integer one ;
GENERIC: two
M: integer two ;
GENERIC: three
M: integer three ;
GENERIC: four
M: integer four ;
PROTOCOL: alpha one two ;
PROTOCOL: beta three ;
TUPLE: hey value ;
C: <hey> hey
CONSULT: alpha hey value>> 1+ ;
CONSULT: beta hey value>> 1- ;
[ 2 ] [ 1 <hey> one ] unit-test
[ 2 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ { 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
[ ] [ "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
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test
[ -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

View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
vectors definitions prettyprint combinators.lib math hashtables sets ;
USING: parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint combinators.lib
math hashtables sets ;
IN: delegate
: protocol-words ( protocol -- words )
@ -22,7 +23,8 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
define ;
: change-word-prop ( word prop quot -- )
rot word-props swap change-at ; inline
@ -31,10 +33,9 @@ M: tuple-class group-words
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ] [
rot group-words -rot
[ consult-method ] 2curry each
] 3bi ;
[ register-protocol ]
[ rot group-words -rot [ consult-method ] 2curry each ]
3bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
@ -45,7 +46,7 @@ M: tuple-class group-words
[ with each ] 2curry each ; inline
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
[ first method forget ] cross-2each ;
: protocol-users ( protocol -- users )
protocol-consult keys ;
@ -53,20 +54,24 @@ M: tuple-class group-words
: lost-words ( protocol wordlist -- lost-words )
>r protocol-words r> diff ;
: bid ( x y q r -- qx rxy )
>r swap >r keep r> r> call ; inline
: forget-old-definitions ( protocol new-wordlist -- )
>r [ protocol-users ] [ protocol-words ] bi r>
swap diff forget-all-methods ;
[ protocol-users ] [ lost-words ] bid forget-all-methods ;
: added-words ( protocol wordlist -- added-words )
swap protocol-words swap diff ;
swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
[ first2 consult-method ] cross-2each ;
[ protocol-consult >alist ] [ added-words ] bid
[ swap first2 consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[ drop H{ } clone \ protocol-consult set-word-prop ]
[ { } like \ protocol-words set-word-prop ] 2bi ;
[
drop \ protocol-consult
[ H{ } assoc-like ] change-word-prop
] [ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;

View File

@ -1,19 +1,23 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections
io definitions kernel continuations listener ;
USING: delegate sequences.private sequences assocs
prettyprint.sections io definitions kernel continuations
listener ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
clone clone-like like new-sequence new-resizable nth nth-unsafe
set-nth set-nth-unsafe length set-length lengthen ;
clone clone-like like new-sequence new-resizable nth
nth-unsafe set-nth set-nth-unsafe length set-length
lengthen ;
PROTOCOL: assoc-protocol
at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
at* assoc-size >alist set-at assoc-clone-like
{ assoc-find 1 } delete-at clear-assoc new-assoc
assoc-like ;
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-until stream-read-quot ;
stream-read1 stream-read stream-read-until
stream-read-quot ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format