diff options
author | Andy Wingo <wingo@pobox.com> | 2014-03-29 07:56:08 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-03-31 18:21:04 +0200 |
commit | a6f823bd027b091114eeca9fe651e1025be1e537 (patch) | |
tree | 21af2b9ed7fbbe431823a0fe3ed01d50caac031e /module/language/cps.scm | |
parent | 1eda52c8adb6eef950ddd7e3ffd0606314fb0ed8 (diff) | |
download | guile-a6f823bd027b091114eeca9fe651e1025be1e537.tar.gz |
Public make-cont-folder
* module/language/cps.scm (make-cont-folder): Add global? parameter, and
make public.
(fold-conts): Adapt.
(fold-local-conts): Use make-cont-folder, and take a function instead
of a continuation.
* module/language/cps/arities.scm (fix-clause-arities, fix-arities*):
* module/language/cps/compile-bytecode.scm (collect-conts):
* module/language/cps/elide-values.scm (elide-values*): Adapt to
fold-local-conts change.
Diffstat (limited to 'module/language/cps.scm')
-rw-r--r-- | module/language/cps.scm | 46 |
1 files changed, 13 insertions, 33 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm index 9101aa108..f8b871ed0 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -136,7 +136,7 @@ ;; Misc. parse-cps unparse-cps - fold-conts fold-local-conts)) + make-cont-folder fold-conts fold-local-conts)) ;; FIXME: Use SRFI-99, when Guile adds it. (define-syntax define-record-type* @@ -439,7 +439,7 @@ (_ (error "unexpected cps" exp)))) -(define-syntax-rule (make-cont-folder seed ...) +(define-syntax-rule (make-cont-folder global? seed ...) (lambda (proc fun seed ...) (define (fold-values proc in seed ...) (if (null? in) @@ -477,17 +477,22 @@ (($ $continue k src exp) (match exp - (($ $fun) (fun-folder exp seed ...)) + (($ $fun) + (if global? + (fun-folder exp seed ...) + (values seed ...))) (_ (values seed ...)))) (($ $letrec names syms funs body) (let-values (((seed ...) (term-folder body seed ...))) - (fold-values fun-folder funs seed ...))))) + (if global? + (fold-values fun-folder funs seed ...) + (values seed ...)))))) (fun-folder fun seed ...))) (define (compute-max-label-and-var fun) - ((make-cont-folder max-label max-var) + ((make-cont-folder #t max-label max-var) (lambda (label cont max-label max-var) (values (max label max-label) (match cont @@ -501,32 +506,7 @@ -1)) (define (fold-conts proc seed fun) - ((make-cont-folder seed) proc fun seed)) + ((make-cont-folder #t seed) proc fun seed)) -(define (fold-local-conts proc seed cont) - (define (cont-folder cont seed) - (match cont - (($ $cont k cont) - (let ((seed (proc k cont seed))) - (match cont - (($ $kargs names syms body) - (term-folder body seed)) - - (($ $kentry self tail clauses) - (fold cont-folder (cont-folder tail seed) clauses)) - - (($ $kclause arity body) - (cont-folder body seed)) - - (_ seed)))))) - - (define (term-folder term seed) - (match term - (($ $letk conts body) - (fold cont-folder (term-folder body seed) conts)) - - (($ $continue) seed) - - (($ $letrec names syms funs body) (term-folder body seed)))) - - (cont-folder cont seed)) +(define (fold-local-conts proc seed fun) + ((make-cont-folder #f seed) proc fun seed)) |