call/cc -> delimited continuations

delimcc.scm

(define-syntax let/cc
  (syntax-rules () [(_ cc e ...) (call/cc (lambda (cc) e ...))]))

(define prompt
  (make-parameter (lambda _ (raise 'undelimited-shift))))

(define (call-with-reset f)
  (let/cc c-frame
    (parameterize
      ([prompt
         (lambda (g)
           (let/cc c-shift
             (define (k v)
               (let/cc c-invoke
                 (set! c-frame c-invoke)
                 (c-shift v)))
             (let ([c c-frame]) (c (g k)))))])
      (let ([r (f)]) (c-frame r)))))

(define-syntax reset
  (syntax-rules () [(_ e ...) (call-with-reset (lambda () e ...))]))

(define (call-with-shift f) ((prompt) f))

(define-syntax shift
  (syntax-rules () [(_ k e ...) (call-with-shift (lambda (k) e ...))]))



(define-syntax test!
  (syntax-rules (: =>)
    [(_ n : e ... => r)
     (let ([res (begin e ...)])
       (when (not (equal? res r))
         (error 'test
           (format "error in ~a: expected ~a, got ~a" n r res))))]
    [(_ e ... => r) (test! 'unnamed : e ... => r)]))

(test! (* 2 (reset (+ 1 (shift k (k 5))))) => 12)
(test! (reset (* 2 (shift k (k (k 4))))) => 16)
(test! (+ 1 (reset (* 2 (shift k (k (k 4)))))) => 17)
(test! (reset (begin (shift k (cons 1 (k (void)))) '())) => '(1))
(test! (reset (begin
                (shift k (cons 1 (k (void))))
                (shift k (cons 2 (k (void))))
                '()))
       => '(1 2))