summaryrefslogtreecommitdiff
path: root/module/language/cps/verify.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/verify.scm')
-rw-r--r--module/language/cps/verify.scm35
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)