用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