Revert part of an earlier ccompiler.tree.checker hange to fix smalltalk.eval regression
parent
85426d1d7d
commit
1dd3ed519f
|
@ -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*
|
||||
|
|
|
@ -29,7 +29,6 @@ SYMBOL: check-optimizer?
|
|||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
?check
|
||||
dup run-escape-analysis? [
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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
|
||||
[ at ] must-infer
|
||||
|
||||
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
|
|
@ -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 ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue