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

give terminating stack effects a pass in the polymorphic checker

db4
Joe Groff 2010-03-05 21:51:38 -08:00
parent 48b433750b
commit 9571bf6d4b
2 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
View File

@ -47,6 +47,8 @@ H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer
H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 1 } } [ [ 1 + ] [ "oops" throw ] if* ] test-poly-infer
[ [ write write ] each ] poly-infer-must-fail
[ [ ] each ] poly-infer-must-fail
[ [ dup ] map ] poly-infer-must-fail
@ -63,9 +65,6 @@ H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer
[ [ ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ 2dup ] if* ] poly-infer-must-fail
[ "derp" each ] poly-infer-must-fail
[ each ] poly-infer-must-fail-unknown
[ "derp" [ "derp" ] if ] poly-infer-must-fail
[ [ "derp" ] "derp" if ] poly-infer-must-fail
[ [ "derp" ] if ] poly-infer-must-fail-unknown

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

@ -55,17 +55,19 @@ M: curried >error-quot
[ 2drop ] if ; inline
:: (check-input) ( declared actual -- )
actual declared [ in>> length ] bi@ declared in-var>>
[ check-variable ] keep :> ( in-diff in-var )
actual declared [ out>> length ] bi@ declared out-var>>
[ check-variable ] keep :> ( out-diff out-var )
{ [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
[
in-var [ in-diff swap adjust-variable ] when*
out-var [ out-diff swap adjust-variable ] when*
] [
abandon-check
] if ;
actual terminated?>> [
actual declared [ in>> length ] bi@ declared in-var>>
[ check-variable ] keep :> ( in-diff in-var )
actual declared [ out>> length ] bi@ declared out-var>>
[ check-variable ] keep :> ( out-diff out-var )
{ [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
[
in-var [ in-diff swap adjust-variable ] when*
out-var [ out-diff swap adjust-variable ] when*
] [
abandon-check
] if
] unless ;
: infer-value ( value -- effect )
dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline
@ -92,9 +94,10 @@ PRIVATE>
: check-polymorphic-effect ( word -- )
current-word get [
dup current-word set stack-effect
dup { [ in-var>> ] [ out-var>> ] } 1||
dup current-word set
stack-effect dup { [ in-var>> ] [ out-var>> ] } 1||
[ infer-polymorphic-vars ] when drop
] dip current-word set ;
SYMBOL: infer-polymorphic?
infer-polymorphic? [ t ] initialize