Fixing delegate reloading
Daniel Ehrenberg
parent
b7006bf456
commit
b38c9f94dc
extra/delegate
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue