我们都知道call/cc是最强大的控制流语句，几乎所有控制流语句（极少特殊的不能）都能用call/cc合成。那么我就来进行一下总结，用call/cc合成所有的控制流结构。如果您觉得有实现不正确的，欢迎在文章底部进行评论，我将对这篇文章进行更新。
除此之外，你还将学习到一些关于scheme宏编写的知识。

除最后一段代码以外均在racket v6.6下测试通过。

while语句

包含while，continue和break。

(require racket/stxparam)

(define-syntax-parameter break (syntax-rules ()))

(define-syntax-parameter continue (syntax-rules ()))

(define-syntax while

  (syntax-rules ()

    [(_ test body ...)

        (call/cc (lambda (k1)

                   (let ([t (void)])

                    (begin (call/cc (lambda (k2) (set! t k2)))

                           (syntax-parameterize

                               ([break (syntax-rules ()

                                         [(_) (k1 (void))])]

                                [continue (syntax-rules ()

                                         [(_) (t (void))])])

                             (when (not test) (break))

                             body ... (continue))))))]))

(let ([a 1])

  (while (< a 10)

         (set! a (+ a 1))

         (display a)))

(let ([a 1])

  (while (< a 10)

         (set! a (+ a 1))

         (when (= a 5) (break))

         (display a)))

(let ([a 1])

  (while (< a 10)

         (set! a (+ a 1))

         (when (= a 5) (continue))

         (display a)))

(let ([a 1])

  (while (< a 10)

         (set! a (+ a 1))

         (let ([b 1])

           (while (< b a)

                (display b)

                (display " ")

                (set! b (+ b 1))

                (when (= b 5) (break))

                )

         (display a)

         (display " "))))

第一个测试输出：2345678910
第二个测试输出：234
第三个测试输出：234678910
第四个测试输出：1 2 1 2 3 1 2 3 4 1 2 3 4 5 1 2 3 4 6 1 2 3 4 7 1 2 3 4 8 1 2 3 4 9 1 2 3 4 10

goto语句

(require racket/stxparam)

(define-syntax-parameter goto (syntax-rules ()))

(define-syntax prog

  (syntax-rules (label)

    [(_ "expanding" ((l1 code1 ...)(l codes ...) ...))

        ((call/cc (lambda (k)

                    (syntax-parameterize ([goto (syntax-rules ()

                                                  [(_ w) (k w)])]

                                                  )

                    (letrec ([l1 (lambda () (let () code1 ...))]

                             [l (lambda () (let () (void) codes ...))] ...)

                      l1)))))]

    [(_ "expanding" (a ... (l codes ...)) (label lname) rest ...)

        (prog "expanding" (a ... (l codes ... (lname)) (lname)) rest ...)]

    [(_ "expanding" (i ... (l codes ...)) code1 rest ...)

        (prog "expanding" (i ... (l codes ... code1)) rest ...)]

    [(_ xxx ...)

        (prog "expanding" ((start-label)) xxx ...)]))

(prog

      (goto k)

      (display "1")

      (label k)

      (display 2)

      )

exception

已经在上一篇文章Dynamic Scoping in Scheme提过，不再赘述。

Generators

很久之前写的东西，代码风格有些不一样。

;;;implement generators in scheme

;;;bugs fixed : Reset the Continuations

(define *meta-cont* (lambda (v) (error "No Top Level generator")))

(define-syntax (generator stx)

  (syntax-case stx ()

    [(generator expr ...)  #`(letrec (

                     [#,(datum->syntax #'generator `*cont*)

                      (lambda (v)

                        (reset expr ...)

                        )])

                     (lambda ()

                        (#,(datum->syntax #'generator `*cont*) (void))

                     ))]))

(define-syntax yield

  (lambda (stx)

    (syntax-case stx ()

      [(yield  v) #`(call/cc (lambda (k)

                            (set! #,(datum->syntax #'yield `*cont*) (lambda (va) (reset (k va))))

                               (*meta-cont* v)

                               ))]

       )))

(define-syntax reset

  (syntax-rules ()

    [(_ expr ...) (let ([preserved *meta-cont*])

                    (call/cc (lambda (k)

                               (set! *meta-cont* (lambda (v) (set! *meta-cont* preserved) (k v)))

                               (let ([result (begin expr ...)])

                                 (*meta-cont* result)

                                     ))))]))

;;example : yielding values

(define y (generator (yield 1)

                     (yield 2)

                     (yield 3)))

(y)

(y)

(y)

;;example : producer and consumer

(define (looper thunk) (thunk) (looper thunk))

(define product #f)

(define p (generator (for-each (lambda (f)

                                 (set! product f)

                                 (display "I have put ")

                                 (display f)

                                 (newline)

                                 (yield (c))) `(apple pea grape banana))))

(define c (generator (looper (lambda ()

                               (display "I have eaten ")

                               (display product)

                               (newline)

                               (set! product #f)

                               (yield (p))))))

(p)

;;example : generator makes infinite stream

(define i (let ([v 0])

              (generator (looper (lambda ()

                            (set! v (+ v 1))

                            (yield (stream-cons v (i))))))))

(define s (i))

(stream-ref s 0)

(stream-ref s 1)

(stream-ref s 2)

(stream-ref s 0)

(stream-ref s 100)

;;example : map generators

(define map-generator

  (lambda (f g)

    (generator (looper (lambda ()

                         (yield (f (g))))))))

(define a (map-generator (lambda (x) (+ 2 x))

           (generator (yield 1)

                     (yield 2)

                     (yield 3))))

(a)

(a)

(a)

tips：这样实现的generator可能会导致memory leaking。

coroutines，fibers

与generator原理类似，但略有不同，基本上每一本scheme语言的教材都有相关的代码，可以看the scheme programming language,4th edititon,就不给代码了。

Partial Continuation

shift/reset

用callcc实现的shift/reset会有效率问题，和上面的generator一样，可能会导致内存泄漏，建议用racket自带的(racket/control)。

(define *meta-cont* (lambda (v) (error "No Top Level reset")))

(define-syntax reset

  (syntax-rules ()

    [(_ expr ...) (let ([preserved *meta-cont*])

                    (call/cc (lambda (k)

                               (set! *meta-cont* (lambda (v) (set! *meta-cont* preserved) (k v)))

                               (let ([result (begin expr ...)])

                                 (*meta-cont* result))

                                 )))]))

(define-syntax shift

  (syntax-rules ()

    [(_ k expr ...) (call/cc

                     (lambda (k1)

                       (let* ([k (lambda (v) (reset (k1 v)))]

                              [v (begin expr ...)]

                              )

                         (*meta-cont* v))))]))

(reset (+ 1 (shift k (k (k 1)))))

(((reset (+ (shift a a) (shift b b))) 1) 3)

shift0/reset0

类似于shift/reset,把meta-cont换成了一个表。

(define *meta-cont* (list (lambda (v) (error "No Top Level rest0"))))

(define-syntax reset0

  (syntax-rules ()

    [(_ expr ...) (call/cc (lambda (k)

                             (set! *meta-cont* (cons k

                                                *meta-cont*

                                                ))

                             (let ([result (begin expr ...)]

                                   [c (car *meta-cont*)]

                                   [e (set! *meta-cont* (cdr *meta-cont*))]

                                   )

                                 (c result))

                                 ))]))

(define-syntax shift0

  (syntax-rules ()

    [(_ k expr ...) (call/cc

                     (lambda (k1)

                       (let* ([k (lambda (v) (reset0 (k1 v)))]

                              [c (car *meta-cont*)]

                              [e (set! *meta-cont* (cdr *meta-cont*))]

                              [v (begin expr ...)]

                              )

                         (c v))))]))

(reset0 (cons 1 (reset0 (shift0 k 2))))

(reset0 (cons 1 (reset0 (shift0 k (shift0 t 2)))))

(reset0 (+ 1 (shift0 k (k (k 1)))))

(reset0 (cons 1 (reset0 (reset0 (shift0 k (shift0 t 1))))))

*meta-cont*

dynamic-wind,unwind-protect

因为tspl上有实现的代码，我把它贴出来一下：（以下代码来自the scheme programming language,4th edititon）

(define dynamic-wind #f)

 (let ((winders '()))

   (define common-tail

     (lambda (x y)

       (let ((lx (length x)) (ly (length y)))

         (do ((x (if (> lx ly) (list-tail x (- lx ly)) x) (cdr x))

              (y (if (> ly lx) (list-tail y (- ly lx)) y) (cdr y)))

             ((eq? x y) x)))))

   (define do-wind

     (lambda (new)

       (let ((tail (common-tail new winders)))

         (let f ((l winders))

           (if (not (eq? l tail))

               (begin

                 (set! winders (cdr l))

                 ((cdar l))

                 (f (cdr l)))))

         (let f ((l new))

           (if (not (eq? l tail))

               (begin

                 (f (cdr l))

                 ((caar l))

                 (set! winders l)))))))

   (set! call/cc

     (let ((c call/cc))

       (lambda (f)

         (c (lambda (k)

              (f (let ((save winders))

                   (lambda (x)

                     (if (not (eq? save winders)) (do-wind save))

                     (k x)))))))))

   (set! call-with-current-continuation call/cc)

   (set! dynamic-wind

     (lambda (in body out)

       (in)

       (set! winders (cons (cons in out) winders))

       (let ((ans (body)))

         (set! winders (cdr winders))

         (out)

         ans))))

engines

很遗憾，这个结构无法用call/cc合成。

recommend readings
1.the scheme programming language,chapter 5
2.applications of continuations,Dan P Friedman
3.schemewiki call-with-current-continuation & composable-continuations-tutorial
4.lisp in small pieces,chapter 3
5.wiki:delimited continuations
6.okmij.org :Continuations and delimited control
7.matt might :Continuations by example: Exceptions, time-traveling search, generators, threads, and coroutines