From bf663e830a7d1138c442e65c9d06a3830cbb1845 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Mar 2009 20:02:31 -0600
Subject: [PATCH] Changing a method into a generated slot accessor would result
 in the generated accessor being forgotten

---
 basis/delegate/delegate-tests.factor  | 18 ++++++++++++++---
 core/classes/tuple/tuple-tests.factor | 28 +++++++++++++++++++++++++++
 core/parser/parser.factor             | 12 ++++++++----
 3 files changed, 51 insertions(+), 7 deletions(-)

diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 4b02407735..ff55fb1282 100644
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -125,7 +125,7 @@ PROTOCOL: silly-protocol do-me ;
 DEFER: slot-protocol-test-3
 SLOT: y
 
-[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -135,7 +135,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -143,4 +143,16 @@ TUPLE: slot-protocol-test-3 x y ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
\ No newline at end of file
+! We now have a real accessor for the y slot; we don't want it to
+! get lost
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+! We want to be able to override methods after consultation
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: delegate kernel sequences delegate.protocols accessors ;
+    TUPLE: override-method-test seq ;
+    CONSULT: sequence-protocol override-method-test seq>> ;
+    M: override-method-test like drop ; ">
+    <string-reader> "delegate-test-2" parse-stream
+] unit-test
\ No newline at end of file
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 8d2610ccd7..d221d28da9 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -703,3 +703,31 @@ TUPLE: bogus-hashcode-2 x ;
 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
 
 [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
+
+DEFER: change-slot-test
+SLOT: kex
+
+[ ] [
+    "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
+    <string-reader> "change-slot-test" parse-stream
+    drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+
+[ ] [
+    "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
+    <string-reader> "change-slot-test" parse-stream
+    drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+
+[ ] [
+    "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
+    <string-reader> "change-slot-test" parse-stream
+    drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
\ No newline at end of file
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index e39422945e..9e578120f4 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -220,10 +220,14 @@ print-use-hook [ [ ] ] initialize
     "quiet" get [ drop ] [ "Loading " write print flush ] if ;
 
 : filter-moved ( assoc1 assoc2 -- seq )
-    swap assoc-diff [
-        drop where dup [ first ] when
-        file get path>> =
-    ] assoc-filter keys ;
+    swap assoc-diff keys [
+        {
+            { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
+            { [ dup "reading" word-prop ] [ f ] }
+            { [ dup "writing" word-prop ] [ f ] }
+            [ t ]
+        } cond nip
+    ] filter ;
 
 : removed-definitions ( -- assoc1 assoc2 )
     new-definitions old-definitions