これは、Lisp Advent Calendar 2014の１２日目の記事です。

Final Shift for Call/cc: Direct Implementation of Shift and Reset
http://www.deinprogramm.de/sperber/papers/shift-reset-direct.pdf
という論文によればshift/reset 演算子は下記のようにcall/cc演算子から作成することができます。

callcc-shift-reset.scm

(define-syntax reset
  (syntax-rules ()
                ((reset ?e) (*reset (lambda () ?e)))))
(define-syntax shift
  (syntax-rules ()
                ((shift ?k ?e) (*shift (lambda (?k) ?e)))))

(define (*meta-continuation* v)
  (error "You forgot the top-level reset..."))

(define (*abort thunk)
  (let ((v (thunk)))
    (*meta-continuation* v)))

(define (*reset thunk)
  (let ((mc *meta-continuation*))
    (call-with-current-continuation
      (lambda (k)
        (begin
          (set! *meta-continuation*
            (lambda (v)
              (set! *meta-continuation* mc)
              (k v)))
          (*abort thunk))))))

(define (*shift f)
  (call-with-current-continuation
    (lambda (k)
      (*abort (lambda ()
                (f (lambda (v)
                     (reset (k v)))))))))

このようなコードを見てしまうと「限定継続を実装するにはやっぱり実装レベルから組み立てないといけないんだなぁ」と思ってしまいます。はたして本当にそうでしょうか。本当にcall/ccは必要なんでしょうか。

初歩:begin文からの脱出

schemeの文は所詮λ式の組み合わせです。1ステップごとに実行を行うbegin文についても同様で、たとえば次のようにマクロとして実装することができます。

begin-macro.scm

(define-syntax BEGIN
  (syntax-rules ()
                ((BEGIN exp) exp)
                ((BEGIN exp1 exp2 ...)
                 ((lambda (e) (BEGIN exp2 ...)) exp1))
                ))

ここで注目してもらいたいのは、(lambda (e) (BEGIN exp2 ...)) という部分はちょうど exp1 の計算の継続になっているということです。つまり exp1 の部分がたとえば (shift (lambda (cont) body)) と継続呼び出しになっていれば、引数 cont の部分に代入される継続は　(lambda (e) (BEGIN exp2 ...))　であるということです。
ではこういう着想をもってbegin文脱出継続（reset/shift）を実装してみましょう。

begin-reset-shift.scm

(define-syntax reset-cps
  (syntax-rules (shift begin)
    ;;;begin part
    ((_ cont (begin exp1))
     (cont exp1))
    ((_ cont (begin (shift proc)))
     (proc cont))
    ((_ cont (begin (shift proc) exp2 ...))
     (let ((programpoint (lambda (res) (reset-cps cont (begin exp2 ...)))))
       (proc programpoint)))
    ((_ cont (begin exp1 exp2 ...))
     (let ((programpoint (lambda (res) (reset-cps cont (begin exp2 ...)))))
       (reset-cps programpoint (begin exp1))))
    ))
(define-syntax reset
  (syntax-rules ()
    ((_ exp)
     (reset-cps id exp))
    ))
(define (id x) x)

見てもらえばわかるように reset マクロ自体は初期値（何もしない継続 id）を与えるためのラッパーです。本体は reset-cps です。最初の引数 cont が現在の継続を明示化しているものです。
なお、やっていることは単純に (begin exp1 exp2 ...) という表現が出てきたときは exp2 ... 以降の評価を継続として現在の継続 cont にスタックさせているだけです。shift が出てきたときは shift の手続きに現在の継続を渡して評価をさせるというものになっています。
実行結果はこんな感じになります。

evaluated.scm

> (reset
   (begin
     (display "1\n")
     (display "2\n")
     (shift (lambda (cont) (cont 0) (display "3 shifted\n")))
     (display "4\n")
     (shift (lambda (cont) (display "5 exit\n")))
     (display "6\n")
     (display "END\n")
     ))
1
2
4
5 exit
3 shifted

見事に限定継続になっていますね。この調子で他の表現についても限定継続を実装できるのではないでしょうか。

手続きからの脱出

単純なアリティ１の手続き (proc value) を考えてみましょう。value を評価するとき、その時点の直後の継続は proc です。value を評価するまえの時点の継続を cont とすると value を評価したときの継続は proc + cont というものになるはずです。

proc-shift-reset.scm

(define-syntax reset-cps
  (syntax-rules (shift begin)
    ((_ cont (shift proc))
     (proc cont))
    ((_ cont (p a)) 
     (reset-cps (connect cont p) a)) 
    ((_ cont a)
     (cont a)) 
   ))  
(define-syntax reset
  (syntax-rules ()
    ((_ exp)
     (reset-cps id exp))
    ))  

(define (connect c-src stacked-proc)
  (lambda (x) 
    (c-src (stacked-proc x))))

(define (id x) x)

実行結果

proc-escape.scm

(reset (succ (succ 
                (shift (lambda (c) (display "continuation\n")             
                         (c 9))))))
continuation
11

というようになります。ただ、一変数にしか対応していないので (+ 1 2) という表現などには対処できません。対処療法的に次のような実装が考えられます。

2-param-shift-reset.scm

(define-syntax reset-cps
  (syntax-rules (shift begin)
    ((_ cont (shift proc))
     (proc cont))
    ((_ cont (p a)) 
     (reset-cps (connect cont p) a)) 
    ((_ cont (p (shift proc) b ))
     (reset-cps (connect cont (lambda (first) (p first b))) (shift proc)))
    ((_ cont (p a (shift proc)))
     (reset-cps (connect cont (lambda (second) (p a second))) (shift proc)))
    ((_ cont a)
     (cont a)) 
   ))

これで (+ 1 (shift (lambda (c) (c 0)))) というような脱出も可能となりますが、かなりad hocな実装なので３変数、４変数と引数が増えたときにどうしようもないです←これが不完全なところ。

まとめ

begin 脱出、手続き脱出を実装するだけでかなり限定継続的なことができる。
他の細かい表現についてはマクロで実装可能かどうかも含めて検討課題
なお、この方式の場合 http://okmij.org/ftp/continuations/against-callcc.html#memory-leak ここでいうメモリリークも発生しない

まとめたコード

shift-reset.scm

(define-syntax reset-cps
  (syntax-rules (shift begin)
    ;;;Begin begin part
    ((_ cont (begin exp1))
     (cont exp1))
    ((_ cont (begin (shift proc)))
     (proc cont))
    ((_ cont (begin (shift proc) exp2 ...))
     (let ((programpoint (lambda (res) (reset-cps cont (begin exp2 ...)))))
       (proc programpoint)))
    ((_ cont (begin exp1 exp2 ...))
     (let ((programpoint (lambda (res) (reset-cps cont (begin exp2 ...)))))
       (reset-cps programpoint (begin exp1))))
   ;;;End begin part
    ((_ cont (shift proc))
     (proc cont))
    ((_ cont (p a)) 
     (reset-cps (connect cont p) a)) 
    ((_ cont (p (shift proc) b ))
     (reset-cps (connect cont (lambda (first) (p first b ...))) (shift proc)))
    ((_ cont (p a (shift proc)))
     (reset-cps (connect cont (lambda (second) (p a second))) (shift proc)))
    ((_ cont (p a b)) 
     (let ((p-curried (curry* (p xa xb))))
       (reset-cps cont ((p-curried a) b))))
    ((_ cont a)
     (cont a))
   ))
(define-syntax reset
  (syntax-rules ()
    ((_ exp)
     (reset-cps id exp))
    ))
(define-syntax curry
  (syntax-rules ()
    ((_ (a) body)
     (lambda (a) body))
    ((_ (a b ...) body)
     (lambda (a) (curry (b ...) body)))))

(define-syntax curry*
  (syntax-rules ()
    ((_ (f args ...))
     (curry (args ...) (f args ...)))))
;;;;Leak test procedure from
;;;;http://okmij.org/ftp/continuations/against-callcc.html#memory-leak  
(define (leak-test1 identity-thunk)
  (let loop ((id (lambda (x) x)))
    (loop (id (identity-thunk)))))

;;;;Some procedures;;;;;
(define (stacking proc-cps)
  (lambda (n)
    (proc-cps n id)))

(define (id x) x)

(define (unitcont a)
  (lambda (k) (k a)))

(define (connect c-src stacked-proc)
  (lambda (x)
    (c-src (stacked-proc x))))
(define (fact-cps n cont)
  (if (= n 0)
    cont
    (fact-cps (- n 1) (lambda (x) (cont (* n x))))))
(define (succ n) (+ 1 n))

※一部テスト中の手続きも入っています。

参考文献

Guy Lewis Steele, Jr. and Gerald Jay Sussman(1976), Lambda: The Ultimate Imperative
Peter J. Landin (1965), A Generalization of Jumps and Labels
Hayo Thielecke (1998), An Introduction to Landin's "A Generalization of Jumps and Labels"
John C.Reynolds (1993), The Discoveries of Continuations
Kenichi Asai, shift/reset プログラミング入門, ACM SIGPLAN Continuation Workshop 2011 チュートリアルセッション資料