愉悅的scheme之旅（2）--用callcc合成控制流

我們都知道call/cc是最強大的控制流語句，幾乎所有控制流語句（極少特殊的不能）都能用call/cc合成。那麼我就來進行一下總結，用call/cc合成所有的控制流結構。如果您覺得有實現不正確的，歡迎在文章底部進行評論，我將對這篇文章進行更新。

除最後一段代碼以外均在racket v6.6下測試通過。

while語句

包含while，continue和break。

(require racket/stxparam)n(define-syntax-parameter break (syntax-rules ()))n(define-syntax-parameter continue (syntax-rules ()))n(define-syntax whilen (syntax-rules ()n [(_ test body ...)n (call/cc (lambda (k1)n (let ([t (void)])n (begin (call/cc (lambda (k2) (set! t k2)))n (syntax-parameterizen ([break (syntax-rules ()n [(_) (k1 (void))])]n [continue (syntax-rules ()n [(_) (t (void))])])n (when (not test) (break))n body ... (continue))))))]))nn(let ([a 1])n (while (< a 10)n (set! a (+ a 1))n (display a)))nn(let ([a 1])n (while (< a 10)n (set! a (+ a 1))n (when (= a 5) (break))n (display a)))nn(let ([a 1])n (while (< a 10)n (set! a (+ a 1))n (when (= a 5) (continue))n (display a)))nn(let ([a 1])n (while (< a 10)n (set! a (+ a 1))n (let ([b 1])n (while (< b a)n (display b)n (display " ")n (set! b (+ b 1))n (when (= b 5) (break))n )n (display a)n (display " "))))n

第一個測試輸出：2345678910

第四個測試輸出：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)n(define-syntax-parameter goto (syntax-rules ()))n(define-syntax progn (syntax-rules (label)n [(_ "expanding" ((l1 code1 ...)(l codes ...) ...))n ((call/cc (lambda (k)n (syntax-parameterize ([goto (syntax-rules ()n [(_ w) (k w)])]n )n (letrec ([l1 (lambda () (let () code1 ...))]n [l (lambda () (let () (void) codes ...))] ...)n l1)))))]n [(_ "expanding" (a ... (l codes ...)) (label lname) rest ...)n (prog "expanding" (a ... (l codes ... (lname)) (lname)) rest ...)]n [(_ "expanding" (i ... (l codes ...)) code1 rest ...)n (prog "expanding" (i ... (l codes ... code1)) rest ...)]n [(_ xxx ...)n (prog "expanding" ((start-label)) xxx ...)]))nn(progn (goto k)n (display "1")n (label k)n (display 2)n )n

exception

已經在上一篇文章Dynamic Scoping in Scheme提過，不再贅述。

Generators

很久之前寫的東西，代碼風格有些不一樣。

;;;implement generators in schemen;;;bugs fixed : Reset the Continuationsn(define *meta-cont* (lambda (v) (error "No Top Level generator")))n(define-syntax (generator stx)n (syntax-case stx ()n [(generator expr ...) #`(letrec (n [#,(datum->syntax #generator `*cont*)n (lambda (v)n (reset expr ...)n )])n (lambda ()n (#,(datum->syntax #generator `*cont*) (void))n ))]))nn(define-syntax yieldn (lambda (stx)n (syntax-case stx ()n [(yield v) #`(call/cc (lambda (k)n (set! #,(datum->syntax #yield `*cont*) (lambda (va) (reset (k va))))n (*meta-cont* v)n ))]n )))nnn(define-syntax resetn (syntax-rules ()n [(_ expr ...) (let ([preserved *meta-cont*])n (call/cc (lambda (k)n (set! *meta-cont* (lambda (v) (set! *meta-cont* preserved) (k v)))n (let ([result (begin expr ...)])n (*meta-cont* result)n ))))]))nn;;example : yielding valuesn(define y (generator (yield 1)n (yield 2)n (yield 3)))n(y)n(y)n(y)nn;;example : producer and consumern(define (looper thunk) (thunk) (looper thunk))n(define product #f)n(define p (generator (for-each (lambda (f)n (set! product f)n (display "I have put ")n (display f)n (newline)n (yield (c))) `(apple pea grape banana))))nn(define c (generator (looper (lambda ()n (display "I have eaten ")n (display product)n (newline)n (set! product #f)n (yield (p))))))nn(p)nn;;example : generator makes infinite streamnn(define i (let ([v 0])n (generator (looper (lambda ()n (set! v (+ v 1))n (yield (stream-cons v (i))))))))n(define s (i))nn(stream-ref s 0)n(stream-ref s 1)n(stream-ref s 2)n(stream-ref s 0)n(stream-ref s 100)nnn;;example : map generatorsnn(define map-generatorn (lambda (f g)n (generator (looper (lambda ()n (yield (f (g))))))))nn(define a (map-generator (lambda (x) (+ 2 x))n (generator (yield 1)n (yield 2)n (yield 3))))nn(a)n(a)n(a)n

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")))n(define-syntax resetn (syntax-rules ()n [(_ expr ...) (let ([preserved *meta-cont*])n (call/cc (lambda (k)n (set! *meta-cont* (lambda (v) (set! *meta-cont* preserved) (k v)))n (let ([result (begin expr ...)])n (*meta-cont* result))n )))]))nn(define-syntax shiftn (syntax-rules ()n [(_ k expr ...) (call/ccn (lambda (k1)n (let* ([k (lambda (v) (reset (k1 v)))]n [v (begin expr ...)]n )n (*meta-cont* v))))]))nn(reset (+ 1 (shift k (k (k 1)))))n(((reset (+ (shift a a) (shift b b))) 1) 3)n

shift0/reset0

類似於shift/reset,把meta-cont換成了一個表（準確說是，棧）。

(define *meta-cont* (list (lambda (v) (error "No Top Level rest0"))))n(define-syntax reset0n (syntax-rules ()n [(_ expr ...) (call/cc (lambda (k)n (set! *meta-cont* (cons kn *meta-cont*n ))n (let ([result (begin expr ...)]n [c (car *meta-cont*)]n [e (set! *meta-cont* (cdr *meta-cont*))]n )n (c result))n ))]))nn(define-syntax shift0n (syntax-rules ()n [(_ k expr ...) (call/ccn (lambda (k1)n (let* ([k (lambda (v) (reset0 (k1 v)))]n [c (car *meta-cont*)]n [e (set! *meta-cont* (cdr *meta-cont*))]n [v (begin expr ...)]n )n (c v))))]))nn(reset0 (cons 1 (reset0 (shift0 k 2))))n(reset0 (cons 1 (reset0 (shift0 k (shift0 t 2)))))n(reset0 (+ 1 (shift0 k (k (k 1)))))n(reset0 (cons 1 (reset0 (reset0 (shift0 k (shift0 t 1))))))n*meta-cont*n

dynamic-wind,unwind-protect

因為tspl上有實現的代碼，我把它貼出來一下：（以下代碼來自the scheme programming language,4th edititon）

(define dynamic-wind #f)n (let ((winders ()))n (define common-tailn (lambda (x y)n (let ((lx (length x)) (ly (length y)))n (do ((x (if (> lx ly) (list-tail x (- lx ly)) x) (cdr x))n (y (if (> ly lx) (list-tail y (- ly lx)) y) (cdr y)))n ((eq? x y) x)))))n (define do-windn (lambda (new)n (let ((tail (common-tail new winders)))n (let f ((l winders))n (if (not (eq? l tail))n (beginn (set! winders (cdr l))n ((cdar l))n (f (cdr l)))))n (let f ((l new))n (if (not (eq? l tail))n (beginn (f (cdr l))n ((caar l))n (set! winders l)))))))n (set! call/ccn (let ((c call/cc))n (lambda (f)n (c (lambda (k)n (f (let ((save winders))n (lambda (x)n (if (not (eq? save winders)) (do-wind save))n (k x)))))))))n (set! call-with-current-continuation call/cc)n (set! dynamic-windn (lambda (in body out)n (in)n (set! winders (cons (cons in out) winders))n (let ((ans (body)))n (set! winders (cdr winders))n (out)n ans))))n

engines

很遺憾，這個結構無法用call/cc合成。

engines是用於模擬搶佔式多任務的控制流。

推薦閱讀&參考文獻

4.lisp in small pieces,chapter 3