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" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] 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 [ [ write write ] each ] poly-infer-must-fail
[ [ ] each ] poly-infer-must-fail [ [ ] each ] poly-infer-must-fail
[ [ dup ] map ] 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 [ [ ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ 2dup ] if* ] poly-infer-must-fail [ [ ] [ 2dup ] if* ] poly-infer-must-fail
[ "derp" each ] poly-infer-must-fail
[ each ] poly-infer-must-fail-unknown [ 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 [ [ "derp" ] if ] poly-infer-must-fail-unknown

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

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