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

Fix verify-cps to work

Browse source 
* module/language/cps/verify.scm (verify-cps): Relax requirements for
  variable names to be symbols.
This commit is contained in:
Andy Wingo 2014-04-04 12:07:24 +02:00
parent 36aeda5b6a
commit b764157a7b
1 changed files with 4 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -77,7 +77,7 @@
(check-label kf k-env)) (check-label kf k-env))
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
(check-label k k-env)) (check-label k k-env))
(($ $kargs ((? symbol? name) ...) (sym ...) body) (($ $kargs (name ...) (sym ...) body)
(unless (= (length name) (length sym)) (unless (= (length name) (length sym))
(error "name and sym lengths don't match" name sym)) (error "name and sym lengths don't match" name sym))
(visit-term body k-env (add-vars sym v-env))) (visit-term body k-env (add-vars sym v-env)))
@ -93,7 +93,7 @@
((? symbol? req) ...) ((? symbol? req) ...)
((? symbol? opt) ...) ((? symbol? opt) ...)
(and rest (or #f (? symbol?))) (and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...) (((? keyword? kw) (? symbol? kwname) kwsym) ...)
(or #f #t)) (or #f #t))
($ $cont kbody (and body ($ $kargs names syms _))) ($ $cont kbody (and body ($ $kargs names syms _)))
alternate)) alternate))
@ -141,7 +141,7 @@
#t) #t)
(($ $fun) (($ $fun)
(visit-fun exp k-env v-env)) (visit-fun exp k-env v-env))
(($ $call (? symbol? proc) (arg ...)) (($ $call proc (arg ...))
(check-var proc v-env) (check-var proc v-env)
(for-each (cut check-var <> v-env) arg)) (for-each (cut check-var <> v-env) arg))
(($ $callk k* proc (arg ...)) (($ $callk k* proc (arg ...))
@ -169,7 +169,7 @@
(for-each (cut visit-cont-body <> k-env v-env) cont) (for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env))) (visit-term body k-env v-env)))
(($ $letrec ((? symbol? name) ...) (sym ...) (fun ...) body) (($ $letrec (name ...) (sym ...) (fun ...) body)
(unless (= (length name) (length sym) (length fun)) (unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term)) (error "letrec syms, names, and funs not same length" term))
(let ((v-env (add-vars sym v-env))) (let ((v-env (add-vars sym v-env)))