Fix stack-checker bug

db4
Slava Pestov 2008-07-28 17:56:15 -05:00
parent c8cafe5706
commit 029e0e4bba
3 changed files with 38 additions and 11 deletions
unfinished
compiler/tree/propagation

View File

@ -276,6 +276,14 @@ IN: compiler.tree.propagation.tests
] final-literals
] unit-test
[ V{ 27 } ] [
[
dup number? over sequence? and [
dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
] [ "B" throw ] if
] final-literals
] unit-test
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop

View File

@ -6,18 +6,24 @@ stack-checker.backend stack-checker.errors stack-checker.visitor
;
IN: stack-checker.branches
: balanced? ( seq -- ? )
: balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ;
: phi-inputs ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
'[ , f pad-left ] map flip
] unless ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
: phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map
dup [ length ] map supremum '[ , f pad-left ] map
flip
] if ;
: unify-values ( values -- phi-out )
dup sift [ known ] map dup all-eq?
[ nip first make-known ] [ 2drop <value> ] if ;
sift dup empty? [ drop <value> ] [
[ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if
] if ;
: phi-outputs ( phi-in -- stack )
[ unify-values ] map ;
@ -26,8 +32,8 @@ SYMBOL: quotations
: unify-branches ( ins stacks -- in phi-in phi-out )
zip dup empty? [ drop 0 { } { } ] [
dup balanced?
[ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
[ quotations get unbalanced-branches-error ]
if
] if ;
@ -72,7 +78,7 @@ SYMBOL: quotations
: infer-if ( -- )
2 consume-d
dup [ known [ curry? ] [ composed? ] bi or ] contains? [
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d
[ rot [ drop call ] [ nip call ] if ]
recursive-state get infer-quot

View File

@ -9,6 +9,16 @@ threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators ;
IN: stack-checker.tests
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
: must-infer-as ( effect quot -- )
>r 1quotation r> [ infer short-effect ] curry unit-test ;
: must-infer ( word/quot -- )
dup word? [ 1quotation ] when
[ infer drop ] curry [ ] swap unit-test ;
\ infer. must-infer
{ 0 2 } [ 2 "Hello" ] must-infer-as
@ -560,3 +570,6 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
: bad-recursion-6 ( quot: ( -- ) -- )
dup bad-recursion-6 call ; inline recursive
[ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as