generic: Correctly forget multi-methods when classes are forgotten

core/generic/generic.factor

@@ -29,6 +29,9 @@ PREDICATE: method < word
 
 ERROR: method-lookup-failed class generic ;
 
+! Multi-methods can return more than one result here
+GENERIC: lookup-methods ( class generic -- seq )
+
 : ?lookup-method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -225,5 +228,9 @@ M: generic subwords
         tri
     ] { } make ;
 
+: lookup-all-methods ( class -- seq )
+    dup implementors
+    [ lookup-methods ] with gather ;
+
 M: class forget-methods
-    [ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;
+    lookup-all-methods forget-all ;

core/generic/multi/multi-tests.factor

@@ -1,8 +1,8 @@
 USING: accessors arrays classes classes.algebra
 classes.dispatch.covariant-tuples classes.dispatch.syntax classes.predicate
-compiler.test generic generic.multi generic.single kernel kernel.private
-literals math math.combinatorics namespaces random sequences strings
-tools.dispatch tools.test tools.time words ;
+compiler.test compiler.units definitions generic generic.multi generic.single
+kernel kernel.private literals math math.combinatorics namespaces random
+sequences strings tools.dispatch tools.test tools.time vectors words ;
 IN: generic.multi.tests
 
 
@@ -300,3 +300,34 @@ DISJOINT: num42 num47 ;
 { f } [ 42 11 2frob ] unit-test
 [ 42 "haha" 2frob ] must-fail
 { t } [ 47 "haha" 2frob ] unit-test
+
+! Forgetting methods on dispatch classes must work
+
+TUPLE: forgettable ;
+GENERIC: forget-me ( x x -- ) multi
+M: number forget-me 2drop ;
+M: D( forgettable fixnum ) forget-me 2drop ;
+
+{ t }
+[ \ forget-me "methods" word-prop
+  D( number ) M\ number forget-me 2array
+  D( forgettable fixnum ) M\ D( forgettable fixnum ) forget-me 2array 2array >vector =
+] unit-test
+
+{ t }
+[ forgettable lookup-all-methods
+  M\ D( forgettable fixnum ) forget-me 1array =
+] unit-test
+
+{ t }
+[ number lookup-all-methods
+  [ "method-generic" word-prop \ forget-me = ] filter
+  M\ number forget-me 1array =
+] unit-test
+
+{  } [ [ forgettable forget ] with-compilation-unit ] unit-test
+
+{ 1 t }
+[ \ forget-me "methods" word-prop [ length ] keep
+  D( number ) M\ number forget-me 2array 1vector =
+] unit-test

core/generic/multi/multi.factor

@@ -136,6 +136,9 @@ M: multi-combination picker current-index get (picker) ;
 PREDICATE: multi-generic < generic
     "combination" word-prop multi-combination? ;
 
+M: multi-generic lookup-methods ( class generic -- seq )
+    "methods" word-prop [ first dispatch-depends-on? ] with filter values ;
+
 ERROR: not-single-dispatch generic ;
 M: multi-generic dispatch# not-single-dispatch ;
 

core/generic/single/single.factor

@@ -25,6 +25,9 @@ PREDICATE: single-generic < generic
 
 M: single-generic make-inline cannot-be-inline ;
 
+M: single-generic lookup-methods ( class generic -- sequence )
+    ?lookup-method [ 1array ] [ f ] if* ;
+
 GENERIC: dispatch# ( word -- n )
 
 M: generic dispatch# "combination" word-prop dispatch# ;