Merge branch 'bags' of git://github.com/littledan/Factor

[factor.git] / basis / stack-checker / backend / backend.factor

diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index ddb1fd0021b75d878dc74fa03d3dd3efff78e72f..51b5f0cdaf6cf58d1294727c17df26534d36f7b7 100644 (file)
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -3,9 +3,10 @@
 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 ;
 FROM: namespaces => set ;
 IN: stack-checker.backend
 
@@ -17,8 +18,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 ;
 
@@ -31,13 +37,17 @@ 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
 
+: shorten-d ( n -- )
+    meta-d shorten-by meta-d length update-inner-d ;
+
 : consume-d ( n -- seq )
-    [ ensure-d ] [ meta-d shorten-by ] bi ;
+    [ ensure-d ] [ shorten-d ] bi ;
 
 : output-d ( values -- ) meta-d push-all ;
 
@@ -127,7 +137,7 @@ M: bad-call summary
 : infer-r> ( n -- )
     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 
-: consume/produce ( effect quot: ( inputs outputs -- ) -- )
+: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
     '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
     [ terminated?>> [ terminate ] when ]
     bi ; inline
@@ -158,3 +168,30 @@ M: bad-call summary
         current-effect
         stack-visitor get
     ] with-scope ; inline
+
+: (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 <declared-effect> :> 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>> <reversed> [| in n |
+        in ?quotation-effect [| effect |
+            word effect variables branches n declare-effect-d
+        ] when*
+    ] each-index ;
+