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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -276,6 +276,14 @@ IN: compiler.tree.propagation.tests
] final-literals ] final-literals
] unit-test ] 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 } ] [ [ V{ string string } ] [
[ [
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop

28
unfinished/stack-checker/branches/branches.factor
View File

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

13
unfinished/stack-checker/stack-checker-tests.factor
View File

@ -9,6 +9,16 @@ threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators ; sequences.private destructors combinators ;
IN: stack-checker.tests 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 \ infer. must-infer
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as
@ -560,3 +570,6 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
: bad-recursion-6 ( quot: ( -- ) -- ) : bad-recursion-6 ( quot: ( -- ) -- )
dup bad-recursion-6 call ; inline recursive dup bad-recursion-6 call ; inline recursive
[ [ [ drop f ] bad-recursion-6 ] infer ] must-fail [ [ [ 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