schemeマクロで実装する（不完全な）reset/shift

これは、[Lisp Advent Calendar 2014](http://qiita.com/advent-calendar/2014/lisp)の１２日目の記事です。
* * *
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演算子から作成することができます。

```scm: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文についても同様で、たとえば次のようにマクロとして実装することができます。

```scm: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）を実装してみましょう。

```scm: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` の手続きに現在の継続を渡して評価をさせるというものになっています。
実行結果はこんな感じになります。

```scm: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` というものになるはずです。

```scm: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)
```

実行結果

```scm:proc-escape.scm
(reset (succ (succ 
                (shift (lambda (c) (display "continuation\n")             
                         (c 9))))))
continuation
11

```

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

```scm: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 ここでいうメモリリークも発生しない

まとめたコード

```scm: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 チュートリアルセッション資料