stack-checker.backend: docs and tests

diff --git a/basis/stack-checker/backend/backend-docs.factor b/basis/stack-checker/backend/backend-docs.factor
index 04a1a46f24c5bb877f24b680ac9bd1caf11f8211..9dc88345d040ce33504b13e9aae1b28fd3b1d7fe 100644 (file)
--- a/basis/stack-checker/backend/backend-docs.factor
+++ b/basis/stack-checker/backend/backend-docs.factor
@@ -1,7 +1,34 @@
-USING: compiler.tree effects help.markup help.syntax quotations sequences
-stack-checker.state stack-checker.visitor ;
+USING: compiler.tree effects help.markup help.syntax math quotations sequences
+stack-checker.state stack-checker.values stack-checker.visitor ;
 IN: stack-checker.backend
 
+HELP: consume-d
+{ $values { "n" integer } { "seq" sequence } }
+{ $description "Consumes 'n' items from the compile time data stack." }
+{ $examples
+  { $example
+    "USING: namespaces prettyprint stack-checker.backend ;"
+    "0 \ <value> set-global [ 3 consume-d ] with-infer 2drop ."
+    "V{ 1 2 3 }"
+  }
+} ;
+
+HELP: end-infer
+{ $description "Called to end the infer context. It outputs a " { $link #return } " node to the " { $link stack-visitor } " containing the remaining items on the data stack." } ;
+
+HELP: ensure-d
+{ $values { "n" integer } { "values" sequence } }
+{ $description "Does something important.." } ;
+
+HELP: infer-literal-quot
+{ $values { "literal" literal-tuple } }
+{ $description "Performs inferencing for a literal quotation." }
+{ $examples
+  { $unchecked-example
+    "[ 3 + * ] <literal> infer-literal-quot"
+  }
+} ;
+
 HELP: infer-quot-here
 { $values { "quot" quotation } }
 { $description "Performs inferencing on the given quotation. This word should only be called in a " { $link with-infer } " context." } ;
@@ -10,10 +37,20 @@ HELP: introduce-values
 { $values { "values" sequence } }
 { $description "Emits an " { $link #introduce } " node to the current " { $link stack-visitor } " which pushes the given values onto the data stack." } ;
 
+HELP: pop-d
+{ $values { "obj" "object" } }
+{ $description "Pops an item from the compile time datastack. If the datastack is empty, a new value is instead introduced." }
+{ $see-also introduce-values } ;
+
+HELP: push-d
+{ $values { "obj" "object" } }
+{ $description "Pushes an item onto the compile time data stack." } ;
+
+HELP: push-literal
+{ $values { "obj" "object" } }
+{ $description "Pushes a literal onto the " { $link literals } " sequence." }
+{ $see-also commit-literals } ;
+
 HELP: with-infer
 { $values { "quot" quotation } { "effect" effect } { "visitor" "a visitor, if any" } }
 { $description "Initializes the inference engine and then runs the given quotation which is supposed to perform the inferencing." } ;
-
-HELP: push-literal
-{ $values { "obj" "something" } }
-{ $description "Pushes a literal onto the " { $link literals } " sequence." } ;

diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor
index 80cbea0b94cebb428cbe0bb7dbba72863d4347d0..dd7c474848218ac9a265264679095abbbe6e87f7 100644 (file)
--- a/basis/stack-checker/backend/backend-tests.factor
+++ b/basis/stack-checker/backend/backend-tests.factor
@@ -1,5 +1,6 @@
-USING: stack-checker.backend tools.test kernel namespaces
-stack-checker.state stack-checker.values sequences assocs ;
+USING: accessors classes.tuple compiler.tree stack-checker.backend tools.test
+kernel namespaces stack-checker.state stack-checker.values
+stack-checker.visitor sequences assocs ;
 IN: stack-checker.backend.tests
 
 [ ] [
@@ -25,4 +26,54 @@ IN: stack-checker.backend.tests
 [ 1 ] [ 1 ensure-d length ] unit-test
 [ 3 ] [ meta-d length ] unit-test
 
-[ ] [ 1 consume-d drop ] unit-test
+{ } [ 1 consume-d drop ] unit-test
+
+{
+    V{ 3 9 8 }
+    H{ { 8 input-parameter } { 9 input-parameter } { 3 input-parameter } }
+} [
+    init-known-values
+    V{ } clone stack-visitor set
+    V{ 3 9 8 } introduce-values
+    stack-visitor get first out-d>>
+    known-values get
+] unit-test
+
+{ V{ 1 2 3 4 5 } } [
+    0 \ <value> set-global init-inference 5 ensure-d
+] unit-test
+
+{ V{ 9 7 3 } } [
+    V{ } clone stack-visitor set
+    V{ 9 7 3 } (meta-d) set
+    end-infer
+    stack-visitor get first in-d>>
+] unit-test
+
+! Because node is an identity-tuple
+: node-seqs-eq? ( seq1 seq2 -- ? )
+    [ [ tuple-slots ] map concat ] bi@ = ;
+
+! pop-d
+{ t } [
+    0 \ <value> set-global [
+        V{ } clone stack-visitor set pop-d
+    ] with-infer 2nip
+    V{ T{ #introduce { out-d { 1 } } } T{ #return { in-d V{ } } } }
+    node-seqs-eq?
+] unit-test
+
+: foo ( x -- )
+    drop ;
+
+{ t } [
+    0 \ <value> set-global [
+        V{ } clone stack-visitor set
+        [ foo ] <literal> infer-literal-quot
+    ] with-infer nip
+    V{
+        T{ #introduce { out-d { 1 } } }
+        T{ #call { word foo } { in-d V{ 1 } } { out-d { } } }
+        T{ #return { in-d V{ } } }
+    } node-seqs-eq?
+] unit-test