Final inheritance fixes

core/classes/tuple/tuple-tests.factor

@@ -542,3 +542,14 @@ USE: vocabs
 [ f ] [ "x" accessor-exists? ] unit-test
 [ f ] [ "y" accessor-exists? ] unit-test
 [ f ] [ "z" accessor-exists? ] unit-test
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+    <string-reader>
+    "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] unit-test

core/generic/standard/standard-tests.factor

@@ -1,7 +1,7 @@
 IN: generic.standard.tests
 USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser ;
+words float-arrays byte-arrays bit-arrays parser namespaces ;
 
 GENERIC: lo-tag-test
 
@@ -137,3 +137,99 @@ M: byte-array small-lo-tag drop "byte-array" ;
 [ "fixnum" ] [ 3 small-lo-tag ] unit-test
 
 [ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+    #! Intentional mistake.
+    call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+    #! Intentional error.
+    drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee construct-boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+
+[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+
+[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+
+[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+
+[ 102000 ] [ executive construct-boa salary ] unit-test
+
+[ ceo construct-boa salary ]
+[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+
+[ intern construct-boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+    T{ a } funky
+    { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test

core/inference/class/class-tests.factor

@@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
     \ >float inlined?
 ] unit-test
 
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+    [ { real float } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
+[ t ] [
+    [ { float real } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
 [ t ] [
     [ 3 + = ] \ equal? inlined?
 ] unit-test

core/inference/class/class.factor

@@ -274,7 +274,7 @@ DEFER: (infer-classes)
     (merge-intervals) r> set-intervals ;
 
 : annotate-merge ( nodes #merge/#entry -- )
-    2dup merge-classes merge-intervals ;
+    [ merge-classes ] [ merge-intervals ] 2bi ;
 
 : merge-children ( node -- )
     dup node-successor dup #merge? [
@@ -290,28 +290,31 @@ DEFER: (infer-classes)
 M: #label infer-classes-before ( #label -- )
     #! First, infer types under the hypothesis which hold on
     #! entry to the recursive label.
-    dup 1array swap annotate-entry ;
+    [ 1array ] keep annotate-entry ;
 
 M: #label infer-classes-around ( #label -- )
     #! Now merge the types at every recursion point with the
     #! entry types.
-    dup annotate-node
+    {
-    dup infer-classes-before
+        [ annotate-node ]
-    dup infer-children
+        [ infer-classes-before ]
-    dup collect-recursion over suffix
+        [ infer-children ]
-    pick annotate-entry
+        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
-    node-child (infer-classes) ;
+        [ node-child (infer-classes) ]
+    } cleave ;
 
 M: object infer-classes-around
-    dup infer-classes-before
+    {
-    dup annotate-node
+        [ infer-classes-before ]
-    dup infer-children
+        [ annotate-node ]
-    merge-children ;
+        [ infer-children ]
+        [ merge-children ]
+    } cleave ;
 
 : (infer-classes) ( node -- )
     [
-        dup infer-classes-around
+        [ infer-classes-around ]
-        node-successor (infer-classes)
+        [ node-successor (infer-classes) ] bi
     ] when* ;
 
 : infer-classes-with ( node classes literals intervals -- )

core/optimizer/inlining/inlining.factor

@@ -71,8 +71,13 @@ DEFER: (flat-length)
 
 ! Partial dispatch of math-generic words
 : normalize-math-class ( class -- class' )
-    { fixnum bignum ratio float complex }
+    {
-    [ class< ] with find nip object or ;
+        fixnum bignum integer
+        ratio rational
+        float real
+        complex number
+        object
+    } [ class< ] with find nip ;
 
 : math-both-known? ( word left right -- ? )
     math-class-max swap specific-method ;

core/parser/parser.factor

@@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs
         nl
     ] when 2drop ;
 
-: filter-moved ( assoc -- newassoc )
+: filter-moved ( assoc1 assoc2 -- seq )
-    [
+    diff [
         drop where dup [ first ] when
         file get source-file-path =
-    ] assoc-subset ;
+    ] assoc-subset keys ;
 
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
     new-definitions old-definitions
-    [ get first2 union ] bi@ diff ;
+    [ get first2 union ] bi@ ;
+
+: removed-classes ( -- assoc1 assoc2 )
+    new-definitions old-definitions
+    [ get second ] bi@ ;
 
 : smudged-usage ( -- usages referenced removed )
-    removed-definitions filter-moved keys [
+    removed-definitions filter-moved [
         outside-usages
         [
             empty? [ drop f ] [
@@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs
     #! If a class word had a compound definition which was
     #! removed, it must go back to being a symbol.
     new-definitions get first2
-    [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ]
+    filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
-    [ swap diff values [ class? ] subset [ reset-class ] each ]
+    removed-classes
-    2bi ;
+    filter-moved [ class? ] subset [ reset-class ] each ;
 
 : forget-smudged ( -- )
     smudged-usage forget-all