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

stack-checker.row-polymorphism: check stack effects correctly when a one-sided polymorphic declared effect is matched to a shallow subtype, for example, ( x -- ..a ) to ( -- ); fixes #88

db4
Joe Groff 2011-09-09 18:08:27 -07:00
parent 8f6c6e5691
commit e293966618
2 changed files with 54 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -42,7 +42,34 @@ IN: stack-checker.row-polymorphism
out-var [ out-diff swap vars adjust-variable ] when*
] when ;
! A bit of a hack. If the declared effect is one-sided monomorphic and the actual effect is a
! shallow subtype of the root effect, adjust it here
:: (balance-actual-depth) ( declared actual -- depth/f )
{
{ [ {
[ declared in-var>> ]
[ declared out-var>> not ]
[ actual out>> length declared out>> length < ]
} 0&& ] [ declared out>> length actual out>> length - ] }
{ [ {
[ declared in-var>> not ]
[ declared out-var>> ]
[ actual in>> length declared in>> length < ]
} 0&& ] [ declared in>> length actual in>> length - ] }
[ f ]
} cond ;
: (balance-by) ( effect n -- effect' )
"x" <array> swap
[ in>> append ]
[ out>> append ]
[ nip terminated?>> ] 2tri <terminated-effect> ;
: balance-actual ( declared actual -- declared actual' )
2dup (balance-actual-depth) [ (balance-by) ] when* ;
: (check-variables) ( vars declared actual -- ? )
balance-actual
[ [ in>> ] [ in-var>> ] check-variable ]
[ [ out>> ] [ out-var>> ] check-variable ]
[ 2drop ] 3tri unify-variables ;

27
basis/stack-checker/stack-checker-tests.factor
View File

@ -501,3 +501,30 @@ USING: alien.c-types alien ;
void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
[ recursive-callback-2 ] must-infer
! test one-sided row polymorphism
: poly-output ( x a: ( x -- ..a ) -- ..a ) call ; inline
[ [ ] poly-output ] must-infer
[ [ f f f ] poly-output ] must-infer
: poly-input ( ..a a: ( ..a -- x ) -- x ) call ; inline
[ [ ] poly-input ] must-infer
[ [ drop drop drop ] poly-input ] must-infer
: poly-output-input ( x a: ( x -- ..a ) b: ( ..a -- y ) -- y ) [ call ] bi@ ; inline
[ [ ] [ ] poly-output-input ] must-infer
[ [ f f f ] [ drop drop drop ] poly-output-input ] must-infer
[ [ [ f f ] [ drop drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ f f f ] [ drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
: poly-input-output ( ..a a: ( ..a -- x ) b: ( x -- ..b ) -- ..b ) [ call ] bi@ ; inline
[ [ ] [ ] poly-input-output ] must-infer
[ [ drop drop drop ] [ f f f ] poly-input-output ] must-infer
[ [ drop drop ] [ f f f ] poly-input-output ] must-infer
[ [ drop drop drop ] [ f f ] poly-input-output ] must-infer