;;; -*- Mode: Scheme -*- ;;;; Composable Continuations ;;;; Expression in CPS ;;; This code is written by Taylor Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. ;;; All of this file contains regular Scheme code, but written in ;;; either a CPS or a meta-CPS. (See, though, the remark above the ;;; definition of the META-CPS macro.) ;;;; Pseudo-CPS Shift & Reset (define cps/reset (lambda (c body) (c (body values)))) (define cps/shift (lambda (c recipient) (recipient values (lambda (c* . vals) (call-with-values (lambda () (apply c vals)) c*))))) ;;;; Meta-CPS Shift & Reset (define identity-continuation (lambda (mc . vals) (apply mc vals))) (define mcps/reset (lambda (mc c body) (body (lambda vals (apply c mc vals)) identity-continuation))) (define mcps/shift (lambda (mc c recipient) (recipient mc identity-continuation (lambda (mc* c* . vals) (apply c (lambda vals* (apply c* mc* vals*)) vals))))) ;;;; Meta-CPS Labelled Composable Continuations ;;; Procedures whose names begin with % are not truly meta-CPS, but ;;; rather primitives used to implement composable continuations. ;;; Meta-continuations here, in contrast to unlabelled shift & reset, ;;; are maps from delimiter identifiers to the actual meta-continuation ;;; corresponding to the delimited continuation. Of course, code ;;; outside this section will never know the difference, because it ;;; will never explicitly touch the meta-continuation, being in perfect ;;; CPS (and involving no explicit returns) before the meta-CPS ;;; conversion anyway. (define (%delimit-continuation delimiter) (lambda (mcs . vals) (cond ((assq delimiter mcs) => (lambda (probe) (apply (cdr probe) mcs vals))) (else (error "outside delimited context" delimiter vals))))) (define (%meta-cons delimiter c mcs) (cons (cons delimiter (lambda (mcs* . vals) (apply c (let recur ((mcs* mcs*)) (cond ((null? mcs*) '()) ((eqv? (caar mcs*) delimiter) (cdr mcs*)) (else (cons (car mcs*) (recur (cdr mcs*)))))) vals))) mcs)) (define *continuation-delimiter* 0) (define (%new-continuation-delimiter) (let ((delimiter *continuation-delimiter*)) (set! *continuation-delimiter* (+ delimiter 1)) delimiter)) ;;; User-visible interface (define make-continuation-delimiter (lambda (mcs c) (c mcs (%new-continuation-delimiter)))) (define call-with-continuation-delimiter (lambda (mcs c recipient) (let ((delimiter (%new-continuation-delimiter))) (with-delimited-continuation mcs c delimiter (lambda (mcs* c*) (recipient mcs* c* delimiter)))))) (define with-delimited-continuation (lambda (mcs c delimiter body) (body (%meta-cons delimiter c mcs) (%delimit-continuation delimiter)))) (define call-with-composable-continuation (lambda (mcs c delimiter recipient) (recipient mcs (%delimit-continuation delimiter) (lambda (mcs* c* . vals) (apply c (%meta-cons delimiter c* mcs*) vals))))) ;;;; Meta-CPS Examples (define (mcps proc) (lambda (mcs c . args) (c mcs (apply proc args)))) ;;; Several useful procedures (define c<= (mcps <=)) (define c+ (mcps +)) (define c* (mcps *)) (define cpair? (mcps pair?)) (define ccar (mcps car)) (define ccdr (mcps cdr)) (define cdisplay (mcps display)) (define cwrite-char (mcps write-char)) (define cwrite (mcps write)) (define cnewline (mcps newline)) (define ccall-with-values (lambda (mcs c producer consumer) (producer mcs (lambda (mcs* . vals) (apply consumer mcs* c vals))))) (define cvalues (lambda (mcs c . vals) (apply c mcs vals))) ;;; Yes, this is a non-standard, Scheme48-specific macro. Load my CPS ;;; converter () ;;; into the environment for syntax definitions (i.e. ,for-syntax ,load ;;; cps-convert.scm) before loading this file. You will need to change ;;; this if you want to run the code in other Scheme systems. E.g., in ;;; MIT Scheme, you might use: ;;; ;;; (define-syntax meta-cps ;;; (rsc-macro-transformer ;;; (lambda (form closing-environment) ;;; closing-environment ;;; (cps-convert-top (cps-convert-top (cadr form)))))) (define-syntax meta-cps (lambda (form rename compare) (cps-convert-top (cps-convert-top (cadr form))))) (define each-integer-in-interval (meta-cps (lambda (from to step delimiter) (call-with-composable-continuation delimiter (lambda (yield) (letrec ((loop (lambda (integer) (if (c<= integer to) (begin (yield integer) (loop (c+ integer step))) 'unspecified)))) (loop from))))))) (define each-element-of-list (meta-cps (lambda (list delimiter) (call-with-composable-continuation delimiter (lambda (yield) (letrec ((loop (lambda (list) (if (cpair? list) (begin (yield (ccar list)) (loop (ccdr list))) 'unspecified)))) (loop list))))))) (define each-element-of-list/state (meta-cps (lambda (list initial-state delimiter) (call-with-composable-continuation delimiter (lambda (yield) (letrec ((loop (lambda (list state) (if (cpair? list) (loop (ccdr list) (yield (ccar list) state)) state)))) (loop list initial-state))))))) ;;; Convenience macro for running expressions in meta-CPS: ;;; ;;; (TEST-META-CPS ) ;;; => ;;; ((META-CPS ) ;;; '() ; top-level meta-continuations (delimiters) ;;; (LAMBDA (MCS VALUE) VALUE)) ; top-level continuation ;;; ;;; Note that, because of the way META-CPS works, identifiers in its ;;; input *cannot* be hygienically renamed, so this can't be a simple ;;; SYNTAX-RULES macro, since that would rename the LAMBDA there. ;;; This, too, you would have to change if you wanted to run examples ;;; in a Scheme system other than Scheme48. (define-syntax test-meta-cps (lambda (form rename compare) `((,(rename 'META-CPS) (LAMBDA () ;** Do not rename LAMBDA! ,(cadr form))) (,(rename 'QUOTE) ()) (,(rename 'LAMBDA) (MCS . VALS) (APPLY VALUES VALS))))) ;;; Example: ;;; ;;; (test-meta-cps ;;; (call-with-continuation-delimiter ;;; (lambda (delimiter) ;;; ((lambda (i) ; No LET (or macros) in CPS converter. ;;; (cwrite-char #\;) ;;; (cwrite i) ;;; (cnewline)) ;;; (each-integer-in-interval 0 9 1 delimiter))))) ;;; ;0 ;;; ;1 ;;; ;2 ;;; ;3 ;;; ;4 ;;; ;5 ;;; ;6 ;;; ;7 ;;; ;8 ;;; ;9 ;;; ;;; (test-meta-cps ;;; (call-with-continuation-delimiter ;;; (lambda (delimiter) ;;; (ccall-with-values ;;; (lambda () ;;; (each-element-of-list/state '(1 78 73 62 3) ;;; 0 ;;; delimiter)) ;;; (lambda (elt sum) ;;; (c+ elt sum)))))) ;;; ;Value: 217