generic.multi: Support call-next-method

core/generic/multi/multi-tests.factor

@@ -102,3 +102,15 @@ M: the-rock test1 2drop 22 ;
 
 ! This should probably fail at definition time already?
 ! [ [ paper1 paper1 broken ] compile-call ] must-fail
+
+
+! Testing call-next-method
+GENERIC: foo ( x x -- x )
+MM: foo ( x: number x: number -- x ) 2drop 42 ;
+MM: foo ( x: fixnum x: fixnum -- x ) 2drop 47 ;
+MM: foo ( x: float x: number -- x ) call-next-method ;
+
+{ 47 } [ 1 1 foo ] unit-test
+{ 47 } [ [ 1 1 foo ] compile-call ] unit-test
+{ 42 } [ 1.1 1 foo ] unit-test
+{ 42 } [ [ 1.1 1 foo ] compile-call ] unit-test

core/generic/multi/multi.factor

@@ -1,8 +1,8 @@
 USING: accessors arrays assocs classes classes.algebra classes.algebra.private
-classes.private combinators definitions effects effects.parser generic
-generic.parser generic.single generic.single.private generic.standard kernel
-make math math.order namespaces parser quotations sequences sets sorting vectors
-words ;
+classes.private combinators definitions effects effects.parser generalizations
+generic generic.parser generic.single generic.single.private generic.standard
+kernel make math math.order namespaces parser quotations sequences sets sorting
+vectors words ;
 
 IN: generic.multi
 
@@ -191,6 +191,21 @@ M: multi-generic dispatch# not-single-dispatch ;
     members
     ;
 
+! This is the equivalent of predicate-def but for covariant-tuples in dispatch
+! context
+: dispatch-predicate-def ( covariant-tuple -- quot )
+    classes>> <reversed>
+    [ 1 + swap '{ [ _ npick _ instance? not ] [ f ] } ] map-index
+    [ t ] suffix
+    '[ _ cond ] ;
+
+M: multi-combination next-method-quot*
+    drop [ class>dispatch ] dip
+    { [ drop dispatch-predicate-def ]
+      [ next-method 1quotation ]
+    } 2cleave
+    '[ _ _ [ inconsistent-next-method ] if ] ;
+
 ERROR: ambiguous-method-specializations classes ;
 
 ! Check all dispatch tuple specs for ambiguous intersections.  Keep those that