用call/cc合成所有的控制流结构

用call/cc合成所有的控制流结构

来源 https://www.jianshu.com/p/e860f95cad51

call/cc 是非常、非常特殊的，因为它根本无法用 Lambda 演算定义。研究中使用了扩展的演算来处理这玩意。演算引入了一个结构算符，以及标记项（它表示将表达式标记为 ），对算符的展开满足

左结构嬗变：

右结构嬗变：

换言之，在「函数」被调用，或者被传入其他函数的时候，其体内所有和参数同标记的标记项都会以相同的形式被「调用」或者「传入其他函数」一次。算符可以将自己「外面」的东西翻到自己里面来。在有这个算符之后，我们就能定义。在式子里就是 Continuation，我们可以看下它会变化成怎样：

被传入：

被调用：

嗯……在 Curry-Howard 同构的层面，call/cc 对应皮尔士定律，它代表着排中律，这条定律是 Lambda 演算所对应的直觉逻辑里没有的。演算经过 C-H 同构可以得到经典逻辑。

我们都知道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

=================== End