diff --git a/core/generic/multi/multi-tests.factor b/core/generic/multi/multi-tests.factor index 150ab26f596..fe63ebd4ea0 100644 --- a/core/generic/multi/multi-tests.factor +++ b/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 diff --git a/core/generic/multi/multi.factor b/core/generic/multi/multi.factor index 6898ea17d6b..7608284b711 100644 --- a/core/generic/multi/multi.factor +++ b/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>> + [ 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