diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index b58998cb49..a714ddf5ab 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -8,6 +8,7 @@ IN: stack-checker.backend.tests V{ } clone \ literals set H{ } clone known-values set 0 input-count set + 0 inner-d-index set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 15fa9f588a..3476866e02 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -6,6 +6,7 @@ continuations assocs combinators compiler.errors accessors math.order definitions 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 ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; @@ -16,8 +17,13 @@ IN: stack-checker.backend [ #introduce, ] tri ; +: update-inner-d ( new -- ) + inner-d-index get min inner-d-index set ; + : pop-d ( -- obj ) - meta-d [ dup 1array introduce-values ] [ pop ] if-empty ; + meta-d + [ dup 1array introduce-values ] + [ pop meta-d length update-inner-d ] if-empty ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -30,7 +36,8 @@ IN: stack-checker.backend [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri [ introduce-values ] [ meta-d push-all ] bi meta-d push-all - ] when swap tail* ; + ] when + swap from-end [ tail ] [ update-inner-d ] bi ; : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 03c45b9487..203c4c8cb9 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -22,7 +22,8 @@ stack-checker.backend stack-checker.branches stack-checker.transforms stack-checker.dependencies -stack-checker.recursive-state ; +stack-checker.recursive-state +stack-checker.row-polymorphism ; IN: stack-checker.known-words : infer-primitive ( word -- ) @@ -98,15 +99,23 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; -: Pdeclared-effect ( x -- x ) - dup - [ word>> P. ] - [ effect>> P. ] - [ value>> known known>callable P. ] tri ; +! : Pdeclared-effect ( x -- x ) +! "-->" P. +! dup +! [ word>> P. ] +! [ effect>> P. ] +! [ value>> known known>callable P. ] tri +! current-effect P. ; +! +! M: declared-effect infer-call* +! [ Pdeclared-effect +! nip value>> (infer-call) ] +! [ "<--" P. +! word>> P. +! current-effect P. ] bi ; M: declared-effect infer-call* - Pdeclared-effect - nip value>> (infer-call) ; + [ nip dup value>> (infer-call) ] with-effect-here check-declared-effect ; M: input-parameter infer-call* \ call unknown-macro-input ; M: object infer-call* \ call bad-macro-input ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 5f798b1760..5148efba4d 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -1,6 +1,6 @@ ! (c)2010 Joe Groff bsd license USING: accessors arrays assocs combinators combinators.short-circuit -continuations effects fry kernel locals math namespaces +continuations effects fry kernel locals math math.order namespaces quotations sequences splitting stack-checker.backend stack-checker.errors @@ -33,3 +33,25 @@ IN: stack-checker.row-polymorphism ] when* ] each-index ; +:: with-effect-here ( quot -- effect ) + inner-d-index get :> old-inner-d-index + input-count get :> old-input-count + meta-d length :> old-meta-d-length + + old-meta-d-length inner-d-index set + quot call + + inner-d-index get :> new-inner-d-index + input-count get :> new-input-count + + old-meta-d-length new-inner-d-index - + new-input-count old-input-count - + :> in + + meta-d length new-inner-d-index - :> out + + new-inner-d-index old-inner-d-index min inner-d-index set + + in "x" out "x" terminated? get ; inline + +: check-declared-effect ( known effect -- ) + [ known>callable P. ] [ P. ] bi* ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 69eb590d48..3ac6a4531f 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -11,6 +11,7 @@ SYMBOL: terminated? ! Number of inputs current word expects from the stack SYMBOL: input-count +SYMBOL: inner-d-index DEFER: commit-literals @@ -46,4 +47,5 @@ SYMBOL: literals terminated? off V{ } clone \ meta-d set V{ } clone literals set - 0 input-count set ; + 0 input-count set + 0 inner-d-index set ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 53f9e307eb..1590cd886d 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -133,4 +133,6 @@ M: composed known>callable M: curried known>callable [ quot>> known known>callable ] [ obj>> known known>callable ] bi prefix ; +M: declared-effect known>callable + value>> known known>callable ;