add a with-effect-here combinator that determines the effect of a scoped subset of the stack checker

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

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 [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+    meta-d
+    [ <value> 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

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 )
+! : Pdeclared-effect ( x -- x )
-    dup
+!     "-->" P.
-    [ word>> P. ]
+!     dup
-    [ effect>> P. ]
+!     [ word>> P. ]
-    [ value>> known known>callable P. ] tri ;
+!     [ 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 dup value>> (infer-call) ] with-effect-here check-declared-effect ;
-    nip value>> (infer-call) ;
 
 M: input-parameter infer-call* \ call unknown-macro-input ;
 M: object infer-call* \ call bad-macro-input ;

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" <array> out "x" <array> terminated? get <terminated-effect> ; inline
+
+: check-declared-effect ( known effect -- )
+    [ known>callable P. ] [ P. ] bi* ;

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 ;

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 ;