diff --git a/basis/stack-checker/backend/backend-docs.factor b/basis/stack-checker/backend/backend-docs.factor index 04a1a46f24..9dc88345d0 100644 --- 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 \ 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 + * ] 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 80cbea0b94..dd7c474848 100644 --- 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 \ 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 \ 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 \ set-global [ + V{ } clone stack-visitor set + [ foo ] 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