stack-checker.state: docs and tests

basis/stack-checker/state/state-docs.factor

@@ -1,6 +1,29 @@
-USING: help.markup help.syntax quotations sequences ;
+USING: compiler.tree effects help.markup help.syntax quotations sequences
+stack-checker.values stack-checker.visitor ;
 IN: stack-checker.state
 
+HELP: terminated?
+{ $var-description "Did the current control-flow path throw an error?" } ;
+
+HELP: current-effect
+{ $values { "effect" effect } }
+{ $description "Returns what the current analysis states stack effect is." }
+{ $examples
+  { $example
+    "USING: namespaces prettyprint stack-checker.state ;"
+    "{ { input-count 2 } { terminated? t } { (meta-d) { 1 2 } } }"
+    "[ current-effect ] with-variables ."
+    "( x x -- x x * )"
+  }
+} ;
+
+HELP: commit-literals
+{ $description "Outputs all remaining literals to the current " { $link stack-visitor } " as " { $link #push } " instructions. They are also pushed onto the compile-time data stack." }
+{ $see-also meta-d } ;
+
+HELP: input-count
+{ $var-description "Number of inputs current word expects from the stack." } ;
+
 HELP: meta-d
 { $values { "stack" sequence } }
 { $description "Compile-time data stack." } ;
@@ -11,3 +34,7 @@ HELP: meta-r
 
 HELP: literals
 { $var-description "Uncommitted literals. This is a form of local dead-code elimination; the goal is to reduce the number of IR nodes which get constructed. Technically it is redundant since we do global DCE later, but it speeds up compile time." } ;
+
+HELP: (push-literal)
+{ $values { "obj" "a literal" } }
+{ $description "Pushes a literal value to the end of the current " { $link stack-visitor } ". The literal is also given a number and registered in the assoc of " { $link known-values } "." } ;

basis/stack-checker/state/state-tests.factor

@@ -0,0 +1,37 @@
+USING: accessors assocs classes.tuple compiler.tree kernel namespaces sequences
+stack-checker.backend stack-checker.recursive-state stack-checker.state
+stack-checker.values stack-checker.visitor tools.test ;
+IN: stack-checker.state.tests
+
+{
+    V{ 1 2 3 }
+} [
+    0 \ <value> set-global
+    init-inference init-known-values
+    V{ 1 2 3 } literals set commit-literals
+    (meta-d) get
+] unit-test
+
+: node-seqs-eq? ( seq1 seq2 -- ? )
+    [ [ tuple-slots ] map concat ] bi@ = ;
+
+{ t t } [
+    23 \ <value> set-global [
+        V{ } clone stack-visitor set
+        33 (push-literal)
+        known-values get 24 of value>> 33 =
+    ] with-infer nip
+    V{
+        T{ #push { literal 33 } { out-d { 24 } } }
+        T{ #return { in-d V{ 24 } } }
+    } node-seqs-eq?
+] unit-test
+
+{ t } [
+    0 \ <value> set-global
+    V{ } clone stack-visitor set
+    V{ [ call ] } literals set commit-literals
+    stack-visitor get
+    V{ T{ #push { literal [ call ] } { out-d { 1 } } } }
+    node-seqs-eq?
+] unit-test

basis/stack-checker/state/state.factor

@@ -6,10 +6,8 @@ compiler.units stack-checker.values stack-checker.visitor
 stack-checker.errors ;
 IN: stack-checker.state
 
-! Did the current control-flow path throw an error?
 SYMBOL: terminated?
 
-! Number of inputs current word expects from the stack
 SYMBOL: input-count
 SYMBOL: inner-d-index
 
@@ -29,9 +27,7 @@ SYMBOL: literals
     [ nip (meta-d) get push ] [ #push, ] 2bi ;
 
 : commit-literals ( -- )
-    literals get [
+    literals get [ [ (push-literal) ] each ] [ delete-all ] bi ;
-        [ [ (push-literal) ] each ] [ delete-all ] bi
-    ] unless-empty ;
 
 : current-stack-height ( -- n ) meta-d length input-count get - ;