+(define-syntax-rule (make-global-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k cont)
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed ...))
+
+ (($ $kfun src meta self tail clause)
+ (let-values (((seed ...) (cont-folder tail seed ...)))
+ (if clause
+ (cont-folder clause seed ...)
+ (values seed ...))))
+
+ (($ $kclause arity body alternate)
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (if alternate
+ (cont-folder alternate seed ...)
+ (values seed ...))))
+
+ (_ (values seed ...)))))))
+
+ (define (fun-folder fun seed ...)
+ (match fun
+ (($ $fun free body)
+ (cont-folder body seed ...))))
+
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (if (null? conts)
+ (values seed ...)
+ (let-values (((seed ...) (cont-folder (car conts) seed ...)))
+ (lp (cdr conts) seed ...))))))
+
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun) (fun-folder exp seed ...))
+ (_ (values seed ...))))
+
+ (($ $letrec names syms funs body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((funs funs) (seed seed) ...)
+ (if (null? funs)
+ (values seed ...)
+ (let-values (((seed ...) (fun-folder (car funs) seed ...)))
+ (lp (cdr funs) seed ...))))))))
+
+ (cont-folder cont seed ...)))
+
+(define-syntax-rule (make-local-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k (and cont ($ $kargs names syms body)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (term-folder body seed ...)))
+ (($ $cont k cont)
+ (proc k cont seed ...))))
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (match conts
+ (() (values seed ...))
+ ((cont) (cont-folder cont seed ...))
+ ((cont . conts)
+ (let-values (((seed ...) (cont-folder cont seed ...)))
+ (lp conts seed ...)))))))
+ (($ $letrec names syms funs body) (term-folder body seed ...))
+ (_ (values seed ...))))
+ (define (clause-folder clause seed ...)
+ (match clause
+ (($ $cont k (and cont ($ $kclause arity body alternate)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (if alternate
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (clause-folder alternate seed ...))
+ (cont-folder body seed ...))))))