diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 4da40f8a2d..7dd4835639 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index 711fb3f151..45c0b6541b 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/unfinished/stack-checker/branches/branches.factor @@ -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 ] 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 ] if ; + sift dup empty? [ drop ] [ + [ known ] map dup all-eq? + [ first make-known ] [ drop ] 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 diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor index e6dfbbdf26..3fcbc2d023 100755 --- a/unfinished/stack-checker/stack-checker-tests.factor +++ b/unfinished/stack-checker/stack-checker-tests.factor @@ -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