From b38c9f94dcedaba71deb4ab2890571289a8c7a13 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 10 May 2008 00:16:46 -0500 Subject: [PATCH] Fixing delegate reloading --- extra/delegate/delegate-tests.factor | 54 +++++++++++++++++++---- extra/delegate/delegate.factor | 35 ++++++++------- extra/delegate/protocols/protocols.factor | 18 +++++--- 3 files changed, 77 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/delegate/delegate-tests.factor diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor old mode 100644 new mode 100755 index 6aa015a74d..ab0ea988ea --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -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 [ foo ] [ bar ] bi ] unit-test @@ -33,11 +34,48 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 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 +CONSULT: alpha hey value>> 1+ ; +CONSULT: beta hey value>> 1- ; + +[ 2 ] [ 1 one ] unit-test +[ 2 ] [ 1 two ] unit-test +[ 0 ] [ 1 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 one ] unit-test +[ 0 ] [ 1 two ] unit-test +[ 0 ] [ 1 three ] unit-test +[ 0 ] [ 1 four ] unit-test +[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test +[ 2 ] [ 1 one ] unit-test +[ -1 ] [ 1 two ] unit-test +[ -1 ] [ 1 three ] unit-test +[ -1 ] [ 1 four ] unit-test +[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test +[ f ] [ hey \ one method ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 39eccfd194..2f35743c61 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -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 ; diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index c1d7e1e4ab..5f9f1e41ac 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -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