! 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
[ 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 ] [
{ 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 )
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? ;