mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

$prompt is now its own kind of CPS term.

Browse source 
* module/language/cps.scm ($prompt): Rework to be its own term kind.
  Now $continue always continues to a single continuation.  Adapt
  callers.
This commit is contained in:
Andy Wingo 2018-01-03 17:17:23 +01:00
parent 29fee39c2a
commit ee15ca1455
22 changed files with 198 additions and 195 deletions
Download patch file Download diff file Expand all files Collapse all files

35
module/language/cps/verify.scm
View file

@ -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)