generic: check valid combination/effect.

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 ] [

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 )

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? ;