diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 1de6ed0e6a..7829f933aa 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -3,7 +3,7 @@ USING: fry arrays generic io io.streams.string kernel math namespaces parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order -definitions sets hints macros stack-checker.state +definitions locals sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state stack-checker.dependencies summary ; FROM: sequences.private => from-end ; @@ -170,3 +170,27 @@ M: bad-call summary : (infer) ( quot -- effect ) [ infer-quot-here ] with-infer drop ; + +: ?quotation-effect ( in -- effect/f ) + dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; + +:: declare-effect-d ( word effect variables branches n -- ) + meta-d length :> d-length + n d-length < [ + d-length 1 - n - :> n' + n' meta-d nth :> value + value known :> known + known word effect variables branches :> known' + known' value set-known + known' branches push + ] [ word unknown-macro-input ] if ; + +:: declare-input-effects ( word -- ) + H{ } clone :> variables + V{ } clone :> branches + word stack-effect in>> [| in n | + in ?quotation-effect [| effect | + word effect variables branches n declare-effect-d + ] when* + ] each-index ; + diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 570b80f2fd..61730d06ec 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry vectors sequences assocs math math.order accessors kernel -combinators quotations namespaces grouping stack-checker.state +combinators quotations namespaces grouping locals stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.values stack-checker.recursive-state ; IN: stack-checker.branches @@ -119,11 +119,19 @@ M: curried curried/composed? drop t ; M: composed curried/composed? drop t ; M: declared-effect curried/composed? known>> curried/composed? ; +:: declare-if-effects ( -- ) + H{ } clone :> variables + V{ } clone :> branches + \ if (( ..a -- ..b )) variables branches 0 declare-effect-d + \ if (( ..a -- ..b )) variables branches 1 declare-effect-d ; + : infer-if ( -- ) 2 literals-available? [ (infer-if) ] [ - drop 2 consume-d + drop 2 ensure-d + declare-if-effects + 2 shorten-d dup [ known curried/composed? ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 4fb54506c5..debe014e33 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -10,29 +10,6 @@ stack-checker.values stack-checker.visitor ; IN: stack-checker.row-polymorphism -: ?quotation-effect ( in -- effect/f ) - dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; - -:: declare-effect-d ( word effect variables branches n -- ) - meta-d length :> d-length - n d-length < [ - d-length 1 - n - :> n' - n' meta-d nth :> value - value known :> known - known word effect variables branches :> known' - known' value set-known - known' branches push - ] [ word unknown-macro-input ] if ; - -:: declare-input-effects ( word -- ) - H{ } clone :> variables - V{ } clone :> branches - word stack-effect in>> [| in n | - in ?quotation-effect [| effect | - word effect variables branches n declare-effect-d - ] when* - ] each-index ; - :: with-effect-here ( quot -- effect ) inner-d-index get :> old-inner-d-index input-count get :> old-input-count diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index a2296ca84f..b8dacdadcc 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -448,6 +448,6 @@ FROM: splitting.private => split, ; [ [ [ ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with [ [ [ ] [ 2dup ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -! edge cases in polymorphic checking +! M\ declared-effect infer-call* didn't properly unify branches { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as