From 4fd1767768c85332913d208c32a6abb8f2a0ce28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 18:32:02 -0600 Subject: [PATCH] Old fix for classes-intersect? no-method bug was incorrect; we were ignoring anonymous classes in compiled-generic-crossref. Also, forget* now calls reset-word so that references to predicates of forgotten classes don't break the compiler with a similar error. --- basis/compiler/tests/redefine12.factor | 20 +++++++++++++++ core/classes/algebra/algebra.factor | 8 ++++++ core/classes/classes-tests.factor | 34 ++++++++++++++++++++++++++ core/classes/classes.factor | 24 +++++++++--------- core/compiler/units/units.factor | 2 +- core/words/words.factor | 12 +++------ 6 files changed, 80 insertions(+), 20 deletions(-) create mode 100644 basis/compiler/tests/redefine12.factor diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor new file mode 100644 index 0000000000..87dc4596e9 --- /dev/null +++ b/basis/compiler/tests/redefine12.factor @@ -0,0 +1,20 @@ +USING: kernel tools.test eval ; +IN: compiler.tests.redefine12 + +! A regression that came about when fixing the +! 'no method on classes-intersect?' bug + +GENERIC: g ( a -- b ) + +M: object g drop t ; + +: h ( a -- b ) dup [ g ] when ; + +[ f ] [ f h ] unit-test +[ t ] [ "hi" h ] unit-test + +TUPLE: jeah ; + +[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test + +[ f ] [ T{ jeah } h ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 51dad033a9..b7e6800950 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -20,6 +20,14 @@ C: anonymous-complement : 2cache ( key1 key2 assoc quot -- value ) >r >r 2array r> [ first2 ] r> compose cache ; inline +GENERIC: valid-class? ( obj -- ? ) + +M: class valid-class? drop t ; +M: anonymous-union valid-class? members>> [ valid-class? ] all? ; +M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ; +M: anonymous-complement valid-class? class>> valid-class? ; +M: word valid-class? drop f ; + DEFER: (class<=) : class<= ( first second -- ? ) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c7900da316..673c108b27 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -79,3 +79,37 @@ USE: multiline : q ( -- b ) j new g ;"> "class-intersect-no-method-b" parse-stream drop ] unit-test + +! Similar problem, but with anonymous classes +[ ] [ + <" IN: classes.test.c + USE: kernel + GENERIC: g ( a -- b ) + M: object g ; + TUPLE: z ;"> + "class-intersect-no-method-c" parse-stream drop +] unit-test + +[ ] [ + <" IN: classes.test.d + USE: classes.test.c + USE: kernel + : q ( a -- b ) dup z? [ g ] unless ;"> + "class-intersect-no-method-d" parse-stream drop +] unit-test + +! Now, the user removes the z class and adds a method, +[ ] [ + <" IN: classes.test.c + USE: kernel + GENERIC: g ( a -- b ) + M: object g ; + TUPLE: j ; + M: j g ;"> + "class-intersect-no-method-c" parse-stream drop +] unit-test + +TUPLE: forgotten-predicate-test ; + +[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test +[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 70fb869c5c..2ce4b934c8 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -32,8 +32,7 @@ SYMBOL: update-map SYMBOL: implementors-map -PREDICATE: class < word - "class" word-prop ; +PREDICATE: class < word "class" word-prop ; : classes ( -- seq ) implementors-map get keys ; @@ -42,9 +41,12 @@ PREDICATE: class < word PREDICATE: predicate < word "predicating" word-prop >boolean ; +M: predicate reset-word + [ call-next-method ] [ { "predicating" } reset-props ] bi ; + : define-predicate ( class quot -- ) - >r "predicate" word-prop first - r> (( object -- ? )) define-declared ; + [ "predicate" word-prop first ] dip + (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ; ] H{ } make-assoc ; : (define-class) ( word props -- ) - >r - dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless - dup reset-class - dup deferred? [ dup define-symbol ] when - dup redefined - dup props>> - r> assoc-union >>props + [ + dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless + dup reset-class + dup deferred? [ dup define-symbol ] when + dup redefined + dup props>> + ] dip assoc-union >>props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 1b6b934dae..72496a5f76 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook : (compiled-generic-usages) ( generic class -- assoc ) [ compiled-generic-usage ] dip [ - 2dup [ class? ] both? + 2dup [ valid-class? ] both? [ classes-intersect? ] [ 2drop f ] if nip ] curry assoc-filter ; diff --git a/core/words/words.factor b/core/words/words.factor index b7b34f1d22..ce1fdf194b 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- ) M: word reset-word { - "unannotated-def" - "parsing" "inline" "recursive" "foldable" "flushable" - "predicating" - "reading" "writing" - "reader" "writer" - "constructing" - "declared-effect" "constructor-quot" "delimiter" + "unannotated-def" "parsing" "inline" "recursive" + "foldable" "flushable" "reading" "writing" "reader" + "writer" "declared-effect" "delimiter" } reset-props ; GENERIC: subwords ( word -- seq ) @@ -261,7 +257,7 @@ M: word forget* dup "forgotten" word-prop [ drop ] [ [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] - [ t "forgotten" set-word-prop ] + [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ] tri ] if ;