用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