diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 096c620c28..ba5b43dc80 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -76,8 +76,8 @@ M: word reset-class drop ; tri ] { } make ; -: class-usages ( class -- assoc ) - [ update-map get at ] closure ; +: class-usages ( class -- seq ) + [ update-map get at ] closure keys ; forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test [ f ] [ \ yo-momma crossref get at ] unit-test @@ -552,11 +553,11 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test -[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ] +[ { subclass-forget-test-2 } ] [ subclass-forget-test-2 class-usages ] unit-test -[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ] +[ { subclass-forget-test-3 } ] [ subclass-forget-test-3 class-usages ] unit-test @@ -565,3 +566,32 @@ unit-test [ subclass-forget-test-3 new ] must-fail [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail + +! More +DEFER: subclass-reset-test +DEFER: subclass-reset-test-1 +DEFER: subclass-reset-test-2 +DEFER: subclass-reset-test-3 + +GENERIC: break-me ( obj -- ) + +[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test + +[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test + +[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test +[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test +[ subclass-forget-test-3 new ] must-fail + +[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test + +[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 0b54d7d69f..5ba0b7e69c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -166,7 +166,7 @@ M: tuple-class update-class 3tri ; : subclasses ( class -- classes ) - class-usages keys [ tuple-class? ] filter ; + class-usages [ tuple-class? ] filter ; : each-subclass ( class quot -- ) >r subclasses r> each ; inline diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 7e64935e07..241858c95b 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -72,10 +72,12 @@ GENERIC: generate-node ( node -- next ) : word-dataflow ( word -- effect dataflow ) [ - dup "cannot-infer" word-prop [ cannot-infer-effect ] when - dup "no-compile" word-prop [ cannot-infer-effect ] when - dup specialized-def over dup 2array 1array infer-quot - finish-word + [ + dup "cannot-infer" word-prop [ cannot-infer-effect ] when + dup "no-compile" word-prop [ cannot-infer-effect ] when + dup specialized-def over dup 2array 1array infer-quot + finish-word + ] maybe-cannot-infer ] with-infer ; : intrinsics ( #call -- quot ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 965c9d8ad8..7bc4c2bb54 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -157,31 +157,31 @@ GENERIC: implementors ( class/classes -- seq ) M: class implementors all-words [ "methods" word-prop key? ] with filter ; -M: assoc implementors +M: sequence implementors all-words [ "methods" word-prop keys - swap [ key? ] curry contains? + swap [ memq? ] curry contains? ] with filter ; : forget-methods ( class -- ) [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; -M: class forget* ( class -- ) - [ - class-usages [ - drop +: forget-class ( class -- ) + class-usages [ + { + [ "predicate" word-prop [ forget ] each ] [ forget-methods ] [ update-map- ] [ reset-class ] - tri - ] assoc-each - ] - [ call-next-method ] bi ; + } cleave + ] each ; -M: assoc update-methods ( class assoc -- ) +M: class forget* ( class -- ) + [ forget-class ] [ call-next-method ] bi ; + +M: sequence update-methods ( class seq -- ) implementors [ - [ update-generic ] - [ make-generic drop ] 2bi + [ update-generic ] [ make-generic drop ] 2bi ] with each ; : define-generic ( word combination -- ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index de5ca6d5e6..8966a38496 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -421,6 +421,9 @@ TUPLE: missing-effect word ; [ "inferred-effect" set-word-prop ] 2tri ; +: maybe-cannot-infer ( word quot -- ) + [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline + : infer-word ( word -- effect ) [ [ @@ -431,7 +434,7 @@ TUPLE: missing-effect word ; finish-word current-effect ] with-scope - ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ; + ] maybe-cannot-infer ; : custom-infer ( word -- ) #! Customized inference behavior diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 92bfc3f3a9..129d5ef2ee 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -539,8 +539,7 @@ SYMBOL: interactive-vocabs : reset-removed-classes ( -- ) removed-classes - filter-moved [ class? ] filter - [ [ forget-methods ] [ reset-class ] bi ] each ; + filter-moved [ class? ] filter [ forget-class ] each ; : fix-class-words ( -- ) #! If a class word had a compound definition which was