1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00

Update verify-cps

* module/language/cps/verify.scm (verify-cps): Update for recent CPS
  changes.
This commit is contained in:
Andy Wingo 2014-04-12 22:42:23 +02:00
parent 6dc886faf1
commit a2acec7c7f

View file

@ -113,14 +113,12 @@
(_
(error "unexpected clause" clause))))
(define (visit-fun fun k-env v-env)
(match fun
(($ $fun (free ...)
($ $cont kbody
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
(define (visit-entry entry k-env v-env)
(match entry
(($ $cont kbody
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free)
(check-src src)
;; Reset the continuation environment, because Guile's
;; continuations are local.
@ -128,6 +126,13 @@
(k-env (add-labels (list ktail) '())))
(when clause
(visit-clause clause k-env v-env))))
(_ (error "unexpected $kfun" entry))))
(define (visit-fun fun k-env v-env)
(match fun
(($ $fun (free ...) entry)
(for-each (cut check-var <> v-env) free)
(visit-entry '() v-env))
(_
(error "unexpected $fun" fun))))
@ -139,6 +144,8 @@
#t)
(($ $prim (? symbol? name))
#t)
(($ $closure kfun n)
#t)
(($ $fun)
(visit-fun exp k-env v-env))
(($ $call proc (arg ...))
@ -184,5 +191,5 @@
(_
(error "unexpected term" term))))
(visit-fun fun '() '())
(visit-entry fun '() '())
fun)