diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index ff55fb1282..e2bea82e68 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline ; +accessors eval multiline generic.standard delegate.protocols +delegate.private assocs ; IN: delegate.tests TUPLE: hello this that ; @@ -35,7 +36,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 f 2 whoa ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test -[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test +[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test @@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ; [ ] [ T{ a-tuple } do-me ] unit-test +! Change method definition to consultation [ [ ] ] [ <" IN: delegate.tests USE: kernel @@ -119,8 +121,17 @@ PROTOCOL: silly-protocol do-me ; CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream ] unit-test +! Method should be there [ ] [ T{ a-tuple } do-me ] unit-test +! Now try removing the consulation +[ [ ] ] [ + <" IN: delegate.tests "> "delegate-test" parse-stream +] unit-test + +! Method should be gone +[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with + ! A slot protocol issue DEFER: slot-protocol-test-3 SLOT: y @@ -155,4 +166,34 @@ TUPLE: slot-protocol-test-3 x y ;"> CONSULT: sequence-protocol override-method-test seq>> ; M: override-method-test like drop ; "> "delegate-test-2" parse-stream +] unit-test + +DEFER: seq-delegate + +! See if removing a consultation updates protocol-consult word prop +[ [ ] ] [ + <" IN: delegate.tests + USING: accessors delegate delegate.protocols ; + TUPLE: seq-delegate seq ; + CONSULT: sequence-protocol seq-delegate seq>> ;"> + "remove-consult-test" parse-stream +] unit-test + +[ t ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? +] unit-test + +[ [ ] ] [ + <" IN: delegate.tests + USING: delegate delegate.protocols ; + TUPLE: seq-delegate seq ;"> + "remove-consult-test" parse-stream +] unit-test + +[ f ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? ] unit-test \ No newline at end of file diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index a4eef54907..5e8d627434 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,10 +2,13 @@ ! Portions copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes.tuple definitions generic -generic.standard hashtables kernel lexer make math parser -generic.parser sequences sets slots words words.symbol fry ; +generic.standard hashtables kernel lexer math parser +generic.parser sequences sets slots words words.symbol fry +locals combinators.short-circuit compiler.units ; IN: delegate + ( group class quot -- consultation ) + f consultation boa ; + +: create-consult-method ( word consultation -- method ) + [ class>> swap first create-method dup fake-definition ] keep + [ drop ] [ "consultation" set-word-prop ] 2bi ; + +PREDICATE: consult-method < method-body "consultation" word-prop ; + +M: consult-method reset-word + [ call-next-method ] [ f "consultation" set-word-prop ] bi ; + +: consult-method-quot ( quot word -- object ) + [ second [ [ dip ] curry ] times ] [ first ] bi + '[ _ call _ execute ] ; + +: consult-method ( word consultation -- ) + [ create-consult-method ] + [ quot>> swap consult-method-quot ] 2bi define ; : change-word-prop ( word prop quot -- ) [ swap props>> ] dip change-at ; inline -: register-protocol ( group class quot -- ) - [ \ protocol-consult ] 2dip - '[ [ _ _ swap ] dip ?set-at ] change-word-prop ; +: each-generic ( consultation quot -- ) + [ [ group>> group-words ] keep ] dip curry each ; inline -: define-consult ( group class quot -- ) - [ register-protocol ] - [ [ group-words ] 2dip '[ _ _ consult-method ] each ] - 3bi ; +: register-consult ( consultation -- ) + [ group>> \ protocol-consult ] [ ] [ class>> ] tri + '[ [ _ _ ] dip ?set-at ] change-word-prop ; + +: consult-methods ( consultation -- ) + [ consult-method ] each-generic ; + +: unregister-consult ( consultation -- ) + [ class>> ] [ group>> ] bi + \ protocol-consult word-prop delete-at ; + +:: unconsult-method ( word consultation -- ) + consultation class>> word first method + dup { [ ] [ "consultation" word-prop consultation eq? ] } 1&& + [ forget ] [ drop ] if ; + +: unconsult-methods ( consultation -- ) + [ unconsult-method ] each-generic ; + +PRIVATE> + +: define-consult ( consultation -- ) + [ register-consult ] [ consult-methods ] bi ; : CONSULT: - scan-word scan-word parse-definition define-consult ; parsing + scan-word scan-word parse-definition + [ save-location ] [ define-consult ] bi ; parsing + +M: consultation where loc>> ; + +M: consultation set-where (>>loc) ; + +M: consultation forget* + [ unconsult-methods ] [ unregister-consult ] bi ; ! Protocols +alist ] [ added-words ] 2bi - [ swap first2 consult-method ] cross-2each ; + [ drop protocol-consult values ] [ added-words ] 2bi + [ swap consult-method ] cross-2each ; : initialize-protocol-props ( protocol wordlist -- ) [ @@ -81,6 +129,11 @@ M: tuple-class group-words : fill-in-depth ( wordlist -- wordlist' ) [ dup word? [ 0 2array ] when ] map ; +: show-words ( wordlist' -- wordlist ) + [ dup second zero? [ first ] when ] map ; + +PRIVATE> + : define-protocol ( protocol wordlist -- ) [ drop define-symbol ] [ fill-in-depth @@ -97,8 +150,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? M: protocol forget* [ f forget-old-definitions ] [ call-next-method ] bi ; -: show-words ( wordlist' -- wordlist ) - [ dup second zero? [ first ] when ] map ; M: protocol definition protocol-words show-words ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 6fb7fc8ad5..178e29fd93 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -23,6 +23,9 @@ TUPLE: redefine-error def ; : remember-definition ( definition loc -- ) new-definitions get first (remember-definition) ; +: fake-definition ( definition -- ) + old-definitions get [ delete-at ] with each ; + : remember-class ( class loc -- ) [ dup new-definitions get first key? [ dup redefine-error ] when ] dip new-definitions get second (remember-definition) ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 93c3e7f75c..351a8f98fd 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -120,7 +120,7 @@ M: method-body crossref? 2bi ; : create-method ( class generic -- method ) - 2dup method dup [ 2nip ] [ + 2dup method dup [ 2nip dup reset-generic ] [ drop [ dup ] 2keep reveal-method diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 9284f8949b..5ec9ea9b3c 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -557,6 +557,9 @@ EXCLUDE: qualified.tests.bar => x ; [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ error>> no-word-error? ] must-fail-with +! Two similar bugs + +! Replace : def with something in << >> [ [ ] ] [ "IN: parser.tests : was-once-a-word-bug ( -- ) ;" "was-once-a-word-test" parse-stream @@ -570,3 +573,20 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test + +! Replace : def with DEFER: +[ [ ] ] [ + "IN: parser.tests : is-not-deferred ( -- ) ;" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test + +[ [ ] ] [ + "IN: parser.tests DEFER: is-not-deferred" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8ee8b27fbc..de3be98ceb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -135,8 +135,7 @@ IN: bootstrap.syntax "DEFER:" [ scan current-vocab create - dup old-definitions get [ delete-at ] with each - set-word + [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri ] define-syntax ":" [