steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

generic: check valid combination/effect.

db4
John Benediktsson 2015-08-05 15:13:23 -07:00
parent 7312f3dc66
commit 4fbbe6b201
3 changed files with 20 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/generic/generic.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.algebra USING: accessors arrays assocs classes classes.algebra
classes.algebra.private classes.maybe classes.private classes.algebra.private classes.maybe classes.private
combinators definitions kernel make namespaces sequences sets combinators definitions kernel make math namespaces sequences
words ; sets words ;
IN: generic IN: generic
! Method combination protocol ! Method combination protocol
@ -186,8 +186,12 @@ M: method forget*
[ call-next-method ] bi [ call-next-method ] bi
] if ; ] if ;
GENERIC# check-combination-effect 1 ( combination effect -- )
M: object check-combination-effect 2drop ;
: define-generic ( word combination effect -- ) : define-generic ( word combination effect -- )
[ nip swap set-stack-effect ] [ [ check-combination-effect ] keep swap set-stack-effect ]
[ [
drop drop
2dup [ "combination" word-prop ] dip = [ 2drop ] [ 2dup [ "combination" word-prop ] dip = [ 2drop ] [

12
core/generic/standard/standard-tests.factor
View File

@ -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 pic-def>> ] unit-test
{ f } [ "xyz" "generic.standard.tests" lookup-word "decision-tree" word-prop ] 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( -- ) ] [ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ] [ error>> bad-dispatch-position? ]
must-fail-with 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 ! Generic words cannot be inlined
{ } [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test { } [ "IN: generic.standard.tests GENERIC: foo ( x -- x )" eval( -- ) ] unit-test
[ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail [ "IN: generic.standard.tests GENERIC: foo ( x -- x ) inline" eval( -- ) ] must-fail
! Moving a method from one vocab to another didn't always work ! Moving a method from one vocab to another didn't always work
GENERIC: move-method-generic ( a -- b ) GENERIC: move-method-generic ( a -- b )

4
core/generic/standard/standard.factor
View File

@ -13,6 +13,10 @@ TUPLE: standard-combination < single-combination # ;
dup 0 < [ bad-dispatch-position ] when dup 0 < [ bad-dispatch-position ] when
standard-combination boa ; standard-combination boa ;
M: standard-combination check-combination-effect
[ dispatch# ] [ in>> length ] bi* over >
[ drop ] [ bad-dispatch-position ] if ;
PREDICATE: standard-generic < generic PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ; "combination" word-prop standard-combination? ;