diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor new file mode 100644 index 0000000000..3bbba0fcb8 --- /dev/null +++ b/basis/stack-checker/backend/backend-tests.factor @@ -0,0 +1,22 @@ +USING: stack-checker.backend tools.test kernel namespaces +stack-checker.state sequences ; +IN: stack-checker.backend.tests + +[ ] [ + V{ } clone meta-d set + V{ } clone meta-r set + 0 d-in set +] unit-test + +[ 0 ] [ 0 ensure-d length ] unit-test + +[ 2 ] [ 2 ensure-d length ] unit-test +[ 2 ] [ meta-d get length ] unit-test + +[ 3 ] [ 3 ensure-d length ] unit-test +[ 3 ] [ meta-d get length ] unit-test + +[ 1 ] [ 1 ensure-d length ] unit-test +[ 3 ] [ meta-d get length ] unit-test + +[ ] [ 1 consume-d drop ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index f8dec5f823..aadd1adbd4 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -17,15 +17,25 @@ IN: stack-checker.backend : peek-d ( -- obj ) pop-d dup push-d ; -: consume-d ( n -- seq ) [ pop-d ] replicate reverse ; - -: output-d ( values -- ) meta-d get push-all ; - -: ensure-d ( n -- values ) consume-d dup output-d ; - : make-values ( n -- values ) [ ] replicate ; +: ensure-d ( n -- values ) + meta-d get 2dup length > [ + 2dup + [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri + [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri + meta-d get push-all + ] when swap tail* ; + +: shorten-by ( n seq -- ) + [ length swap - ] keep shorten ; inline + +: consume-d ( n -- seq ) + [ ensure-d ] [ meta-d get shorten-by ] bi ; + +: output-d ( values -- ) meta-d get push-all ; + : produce-d ( n -- values ) make-values dup meta-d get push-all ; @@ -35,7 +45,10 @@ IN: stack-checker.backend meta-r get dup empty? [ too-many-r> inference-error ] [ pop ] if ; -: consume-r ( n -- seq ) [ pop-r ] replicate reverse ; +: consume-r ( n -- seq ) + meta-r get 2dup length > + [ too-many-r> inference-error ] when + [ swap tail* ] [ shorten-by ] 2bi ; : output-r ( seq -- ) meta-r get push-all ;