diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 88ab8ef80e..c861f7c54b 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.algebra classes.algebra.private classes.maybe classes.private -combinators definitions kernel make namespaces sequences sets -words ; +combinators definitions kernel make math namespaces sequences +sets words ; IN: generic ! Method combination protocol @@ -186,8 +186,12 @@ M: method forget* [ call-next-method ] bi ] if ; +GENERIC# check-combination-effect 1 ( combination effect -- ) + +M: object check-combination-effect 2drop ; + : define-generic ( word combination effect -- ) - [ nip swap set-stack-effect ] + [ [ check-combination-effect ] keep swap set-stack-effect ] [ drop 2dup [ "combination" word-prop ] dip = [ 2drop ] [ diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index edaa71eed6..fdf1fd7b63 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -365,14 +365,20 @@ M: c funky* "c" , call-next-method ; { f } [ "xyz" "generic.standard.tests" lookup-word pic-def>> ] unit-test { f } [ "xyz" "generic.standard.tests" lookup-word "decision-tree" word-prop ] unit-test -! Corner case +! Corner cases +[ "IN: generic.standard.tests GENERIC: broken-generic ( -- )" eval( -- ) ] +[ error>> bad-dispatch-position? ] +must-fail-with [ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] [ error>> bad-dispatch-position? ] must-fail-with +[ "IN: generic.standard.tests GENERIC# broken-generic# 1 ( a -- b )" eval( -- ) ] +[ error>> bad-dispatch-position? ] +must-fail-with ! Generic words cannot be inlined -{ } [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test -[ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail +{ } [ "IN: generic.standard.tests GENERIC: foo ( x -- x )" eval( -- ) ] unit-test +[ "IN: generic.standard.tests GENERIC: foo ( x -- x ) inline" eval( -- ) ] must-fail ! Moving a method from one vocab to another didn't always work GENERIC: move-method-generic ( a -- b ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index e8b342e777..c214e2f999 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -13,6 +13,10 @@ TUPLE: standard-combination < single-combination # ; dup 0 < [ bad-dispatch-position ] when standard-combination boa ; +M: standard-combination check-combination-effect + [ dispatch# ] [ in>> length ] bi* over > + [ drop ] [ bad-dispatch-position ] if ; + PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ;