diff options
Diffstat (limited to 'module/language/cps/verify.scm')
-rw-r--r-- | module/language/cps/verify.scm | 35 |
1 files changed, 17 insertions, 18 deletions
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 1e0537046..9020c5efc 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -102,12 +102,12 @@ definitions that are available at LABEL." (($ $kargs names vars term) (let ((out (fold1 adjoin-def vars in))) (match term - (($ $continue k src exp) - (match exp - (($ $prompt escape? tag handler) (propagate2 k handler out)) - (_ (propagate1 k out)))) + (($ $continue k) + (propagate1 k out)) (($ $branch kf kt) - (propagate2 kf kt out))))) + (propagate2 kf kt out)) + (($ $prompt k kh) + (propagate2 k kh out))))) (($ $kreceive arity k) (propagate1 k in)) (($ $kfun src meta self tail clause) @@ -164,9 +164,6 @@ definitions that are available at LABEL." (visit-first-order kfun)) (($ $primcall name param args) (for-each check-use args) - first-order) - (($ $prompt escape? tag handler) - (check-use tag) first-order))) (define (visit-term term bound first-order) (define (check-use var) @@ -203,12 +200,12 @@ definitions that are available at LABEL." (visit-first-order kfun)) (($ $primcall name param args) (for-each check-use args) - first-order) - (($ $prompt escape? tag handler) - (check-use tag) first-order))) (($ $branch kf kt src name param args) (for-each check-use args) + first-order) + (($ $prompt k kh src escape? tag) + (check-use tag) first-order))) (intmap-fold (lambda (label bound first-order) @@ -285,12 +282,7 @@ definitions that are available at LABEL." (($ $kreceive) #t) (($ $ktail) (unless (memv name '(throw throw/value throw/value+data)) - (error "primitive should continue to $kargs, not $ktail" name))))) - (($ $prompt escape? tag handler) - (assert-nullary) - (match (intmap-ref conts handler) - (($ $kreceive) #t) - (cont (error "bad handler" cont)))))) + (error "primitive should continue to $kargs, not $ktail" name))))))) (define (check-term term) (match term (($ $continue k src exp) @@ -301,7 +293,14 @@ definitions that are available at LABEL." (cont (error "bad kf" cont))) (match (intmap-ref conts kt) (($ $kargs () ()) #t) - (cont (error "bad kt" cont)))))) + (cont (error "bad kt" cont)))) + (($ $prompt k kh src escape? tag) + (match (intmap-ref conts k) + (($ $kargs () ()) #t) + (cont (error "bad prompt body" cont))) + (match (intmap-ref conts kh) + (($ $kreceive) #t) + (cont (error "bad prompt handler" cont)))))) (let ((reachable (compute-reachable-labels conts kfun))) (intmap-for-each (lambda (label cont) |