diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 718def367d..e25f152aef 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -144,15 +144,13 @@ M: #terminate check-stack-flow* SYMBOL: branch-out -: check-branch ( nodes -- datastack ) +: check-branch ( nodes -- stack ) [ datastack [ clone ] change - retainstack [ clone ] change - retainstack get clone [ (check-stack-flow) ] dip - terminated? get [ drop f ] [ - retainstack get assert= - datastack get - ] if + V{ } clone retainstack set + (check-stack-flow) + terminated? get [ assert-retainstack-empty ] unless + terminated? get f datastack get ? ] with-scope ; M: #branch check-stack-flow* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 182de28cd9..4fb5bab96f 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -84,8 +84,11 @@ M: object apply-object push-literal ; meta-r empty? [ too-many->r ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? - [ commit-literals ] [ literals get delete-all ] if ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -113,33 +116,25 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - terminated? get [ drop ] [ - consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi - ] if ; + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; : infer-r> ( n -- ) - terminated? get [ drop ] [ - consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi - ] if ; - -: (consume/produce) ( effect -- inputs outputs ) - [ in>> length consume-d ] [ out>> length produce-d ] bi ; + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; : consume/produce ( effect quot: ( inputs outputs -- ) -- ) - '[ (consume/produce) @ ] + '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline +: apply-word/effect ( word effect -- ) + swap '[ _ #call, ] consume/produce ; + : end-infer ( -- ) - terminated? get [ check->r ] unless meta-d clone #return, ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: apply-word/effect ( word effect -- ) - swap '[ _ #call, ] consume/produce ; - : infer-word ( word -- ) { { [ dup macro? ] [ do-not-compile ] } diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 9f5d0a2213..919cd098f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -299,7 +299,7 @@ ERROR: custom-error ; [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 1 t } ] [ +[ T{ effect f 1 2 t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test @@ -369,4 +369,6 @@ DEFER: eee' [ [ cond ] infer ] must-fail [ [ bi ] infer ] must-fail -[ at ] must-infer \ No newline at end of file +[ at ] must-infer + +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 9b87854b69..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -42,7 +42,6 @@ SYMBOL: literals : init-inference ( -- ) terminated? off V{ } clone \ meta-d set - V{ } clone \ meta-r set V{ } clone literals set 0 d-in set ;