Consultations now implement the definition protocol; removing one from a source file forgets consulted methods

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 <hello> f <goodbye> 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 ; "> <string-reader> "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 "> <string-reader> "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
@@ -156,3 +167,33 @@ TUPLE: slot-protocol-test-3 x y ;">
     M: override-method-test like drop ; ">
     <string-reader> "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>> ;">
+    <string-reader> "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 ;">
+    <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ f ] [
+    seq-delegate
+    sequence-protocol \ protocol-consult word-prop
+    key?
+] unit-test

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.standard hashtables kernel lexer math parser
-generic.parser sequences sets slots words words.symbol fry ;
+generic.parser sequences sets slots words words.symbol fry
+locals combinators.short-circuit compiler.units ;
 IN: delegate
 
+<PRIVATE
+
 : protocol-words ( protocol -- words )
     \ protocol-words word-prop ;
 
@@ -27,27 +30,72 @@ M: tuple-class group-words
 
 ! Consultation
 
-: consult-method ( word class quot -- )
+TUPLE: consultation group class quot loc ;
-    [ drop swap first create-method-in ]
+
-    [ nip [ swap [ second [ [ dip ] curry ] times % ] [ first , ] bi ] [ ] make ] 3bi
+: <consultation> ( 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 -- )
+: each-generic ( consultation quot -- )
-    [ \ protocol-consult ] 2dip
+    [ [ group>> group-words ] keep ] dip curry each ; inline
-    '[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
 
-: define-consult ( group class quot -- )
+: register-consult ( consultation -- )
-    [ register-protocol ]
+    [ group>> \ protocol-consult ] [ ] [ class>> ] tri
-    [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
+    '[ [ _ _ ] dip ?set-at ] change-word-prop ;
-    3bi ;
+
+: 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 <consultation>
+    [ save-location ] [ define-consult ] bi ; parsing
+
+M: consultation where loc>> ;
+
+M: consultation set-where (>>loc) ;
+
+M: consultation forget*
+    [ unconsult-methods ] [ unregister-consult ] bi ;
 
 ! Protocols
+<PRIVATE
 
 : cross-2each ( seq1 seq2 quot -- )
     [ with each ] 2curry each ; inline
@@ -69,8 +117,8 @@ M: tuple-class group-words
     swap protocol-words diff ;
 
 : add-new-definitions ( protocol wordlist -- )
-    [ drop protocol-consult >alist ] [ added-words ] 2bi
+    [ drop protocol-consult values ] [ added-words ] 2bi
-    [ swap first2 consult-method ] cross-2each ;
+    [ 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 ;
 

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) ;

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
         [ <method> dup ] 2keep
         reveal-method

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 ( -- ) ;"
     <string-reader> "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 ( -- ) ;"
+    <string-reader> "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"
+    <string-reader> "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

core/syntax/syntax.factor

@@ -135,8 +135,7 @@ IN: bootstrap.syntax
 
     "DEFER:" [
         scan current-vocab create
-        dup old-definitions get [ delete-at ] with each
+        [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
-        set-word
     ] define-syntax
 
     ":" [