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

stack-checker.row-polymorphism: fixes bootstrap. i dont know why cond and 0|| are breaking things yet..

locals-and-roots
Doug Coleman 2016-05-16 15:45:02 -07:00
parent bcdedab579
commit 6c7a537d46
1 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
core/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -34,7 +34,10 @@ IN: stack-checker.row-polymorphism
[ vars (check-variable) ] keep ; inline [ vars (check-variable) ] keep ; inline
:: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? ) :: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
{ [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& dup [ in-ok?
out-ok? and
in-diff out-diff = and
dup [
in-var [ in-diff swap vars adjust-variable ] when* in-var [ in-diff swap vars adjust-variable ] when*
out-var [ out-diff swap vars adjust-variable ] when* out-var [ out-diff swap vars adjust-variable ] when*
] when ; ] when ;
@ -42,19 +45,19 @@ IN: stack-checker.row-polymorphism
! A bit of a hack. If the declared effect is one-sided monomorphic and the actual effect is a ! 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 ! shallow subtype of the root effect, adjust it here
:: (balance-actual-depth) ( declared actual -- depth/f ) :: (balance-actual-depth) ( declared actual -- depth/f )
{ declared in-var>>
{ [ { declared out-var>> not and
[ declared in-var>> ] actual out>> length declared out>> length < and [
[ declared out-var>> not ] declared out>> length actual out>> length -
[ actual out>> length declared out>> length < ] ] [
} 0&& ] [ declared out>> length actual out>> length - ] } declared in-var>> not
{ [ { declared out-var>> and
[ declared in-var>> not ] actual in>> length declared in>> length < and [
[ declared out-var>> ] declared in>> length actual in>> length -
[ actual in>> length declared in>> length < ] ] [
} 0&& ] [ declared in>> length actual in>> length - ] } f
[ f ] ] if
} cond ; ] if ;
: (balance-by) ( effect n -- effect' ) : (balance-by) ( effect n -- effect' )
"x" <array> swap "x" <array> swap