Delimited continuations in terms of call/cc

dc.rkt

;; Delimited continuations

#lang racket ; but will work in any Scheme (without this line)

;; There are other implementations along the same lines floating around.
;; Here we are trying to paint a more comprehensible (or at least a less
;; incomprehensible) picture by structuring the implementation as three
;; distinct layers:

;; Layer 1
;;
;; The "stackable labels" mechanism. Introduces 'label!' and 'jump!' control
;; primitives similar in spirit to the common labels and gotos. The difference
;; is that labels and jumps are not labeled. Instead, there is an implicit stack
;; of labels. A label is pushed onto it when a 'label!' expression is evaluated.
;; A 'jump!' pops the top label off the stack and jumps to it, in effect
;; returning from the 'label!' expression that set the label. The 'jump!'
;; expression itself never returns.

(define labels '())
;; The stack can also be implemented as a variable bound to a wrapper closure which
;; rebinds it to the previous closure and then invokes the wrapped continuation.
;; But a mundane stack of cons cells is more instructive and easy to examine.

(define-syntax label!
  (syntax-rules ()
    ((push-label! expr)
     (call-with-current-continuation
      (lambda (k)
        (set! labels (cons k labels))
        expr)))))

(define (jump! v)
  (let ((k (car labels)))
    (set! labels (cdr labels))
    (k v)))

;; Layer 2
;;
;; Effectively shift and reset, cast as higher-order functions
;; shift/0 and reset/0 to separate the actual control logic from the
;; delaying of evaluation required by the real shift and reset.

(define (reset/0 body)
  (label! (jump! (body))))

(define (shift/0 body)
  (call-with-current-continuation
   (lambda (k)
     (jump! (body (escaper k))))))

(define (escaper k)
  (lambda (v)
    (label! (k v))))

;; Layer 3
;;
;; The actual shift and reset--straightforward and ultimately unimportant.

(define-syntax reset
  (syntax-rules ()
    ((reset e ...) (reset/0 (lambda () e ...)))))

(define-syntax shift
  (syntax-rules ()
    ((shift r e ...) (shift/0 (lambda (r) e ...)))))

;; Examples

(define (ex1)  ; should be 7
  (reset (+ 3 4)))

(define (ex2)  ; should be 4
  (reset (+ 3 (shift k 4))))

(define (ex3) ; should be 7
  (reset (+ 3 (shift k (k 4)))))

(define (ex4)  ; should be 12
  (* 2 (reset (+ 1 (shift k (k 5))))))

(define (ex5)  ; should be 16
  (reset (* 2 (shift k (k (k 4))))))

(define (ex6)  ; should be 14
  (reset (* 2 (shift k (+ (k 3) (k 4))))))

(define (ex7) ; should display a12b12
  (reset
      (display (shift k (k "a") (k "b")))
      (display (shift k (k 1) (k 2)))))