神刀安全网

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

前言

我们都知道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会有效率问题,并且会导致内存泄漏,建议用racket自带的。

(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 reading
1.the scheme programming language,chapter 5
2.application of continuations,Dan P Friedman
3.schemewiki call-with-current-continuation & composable-continuations-tutorial
4.lisp in small pieces,chapter 3

转载本站任何文章请注明:转载至神刀安全网,谢谢神刀安全网 » 用call/cc合成所有的控制流结构

分享到:更多 ()

评论 抢沙发

  • 昵称 (必填)
  • 邮箱 (必填)
  • 网址