Fix stack-checker bug
parent
c8cafe5706
commit
029e0e4bba
unfinished
compiler/tree/propagation
stack-checker
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue