Scheme 的 call/cc

scheme 标准库中有一个 member 过程，它接收一个元素和一个列表，判断元素是否属于列表。若是则返回包含该元素的表，否则返回 #f。它的一个简单实现如下：

(define member
   (lambda (x ls)
      (cond
         ((null? ls) #f)
         ((equal? x (car ls)) ls)
         (else (member x (cdr ls))))))

这个过程是尾递归的，也就是说它会被优化为循环，如果 ls 中没有找到 x 元素的话，member 会直接向它的调用者返回 #f。但假设（仅仅是假设）没有尾递归的话，#f 需要逐级向上返回，直到返回到第一级 member 调用时才会将 #f 返回给调用者。使用 call/cc 可以在查找不到 x 元素时直接向调用者返回 #f：

(define member
   (lambda (x ls)
      (call/cc (lambda (k)
                  (let f ([ls ls])
                    (cond
                      ((null? ls) (k #f))
                      ((equal? (car ls) x) (k ls))
                      (else (f (cdr ls)))))))))

这并不是一个很好的例子，有种没有需求就创造需求的感觉。

说到回溯，有一个运算符与它有着紧密的联系，那就是 amb 。amb 是 ambiguous 的一个缩写，它用于非确定性计算。

参考资料【7】对 amb 进行了描述： amb 接收一个或多个表达式，并在它们中进行一次非确定选择，这个选择使得程序趋向于有意义。不带参数调用 amb 不会有返回值并会出错。

举个例子 (amb 1 2) 会返回 1 或 2，因为两个值都是有意义的。但是 (amb 1 (amb)) 会返回 1，因为 (amb) 是无意义的。

参考资料【6】给出了 amb 的一个实现，这里直接拿过来了：

;;; FAIL is called to backtrack when a condition fails.  At the top
;;; level, however, there is no more to backtrack, so we signal an
;;; error with SRFI 23.
(define fail
  (lambda ()
    (raise "Amb tree exhausted")))

(define-syntax amb
  (syntax-rules ()
    ((amb) (fail))                      ; Two shortcuts.
    ((amb expression) expression)
    ((amb expression ...)
     (let ((fail-save fail))
       ((call/cc                        ; Capture a continuation to
          (lambda (k-success)           ;   which we return possibles.
            (call/cc
              (lambda (k-failure)       ; K-FAILURE will try the next
                (set! fail              ;   possible expression.
                      (lambda () (k-failure #f)))
                (k-success              ; Note that the expression is
                 (lambda ()             ;   evaluated in tail position
                   expression))))       ;   with respect to AMB.
            ...
            (set! fail fail-save)      ; Finally, if this is reached,
            fail-save)))))))           ;   we restore the saved FAIL.

(define (require condition)
  (if (not condition)
      (fail)))

;;; As an auxiliary example, AMB-POSSIBILITY-LIST is a special form
;;; that returns a list of all values its input expression may return.

(define-syntax amb-possibility-list
  (syntax-rules ()
    ((amb-possibility-list expression)
     (let ((value-list '()))
       ;; This requires that AMB try its sub-forms left-to-right.
       (amb (let ((value expression))
              (set! value-list (cons value value-list))
              (fail))
            (reverse value-list))))))   ; Order it nicely.

上面的定义使用了宏来对参数数量进行判断，零参数时直接调用 fail，单参数时使用参数值作为返回值。这个宏定义的要点在于多参数的情况，而它的核心代码就是：

(call/cc
  (lambda (k-failure)
     (set! fail
        (lambda () (k-failure #f)))
     (k-success
        (lambda ()
          expression))))
...

多个表达式的展开表示如下：

(call/cc
  (lambda (k-failure)
     (set! fail
        (lambda () (k-failure #f)))
     (k-success
        (lambda ()
          expression1))))
(call/cc
  (lambda (k-failure)
     (set! fail
        (lambda () (k-failure #f)))
     (k-success
        (lambda ()
          expression2))))
(call/cc
  (lambda (k-failure)
     (set! fail
        (lambda () (k-failure #f)))
     (k-success
        (lambda ()
          expression3))))
...

初始条件下，将 fail 设置为当前捕获的 k-failure 后，接着调用 k-success 返回当前（第一个）表达式的值。此后，调用 fail 即可返回到 k-failure 处，并将 #f 作为 call/cc 表达式的值，接着向下继续顺序求值。那么应该在什么时候调用 fail 呢？那就是 require 条件不满足的时候。调用 fail 后，#f 作为某个 expression 的值，并接着使用下一个 expression，直到满足条件为止。

例如，以下代码：

(let ((a (amb 1 2))
      (b (amb 1 2)))
   (require (< a b))
   (list a b))

得到的结果为 (1 2) ，因为只有它满足 (require (< a b) 。

上面使用了 raise 过程，如果有的 scheme 实现使用 error，可以将 raise 替换为 error。某些实现也可能已经定义了 require 标识符，可以将它替换为其他的标识符。

协程是一般化的子函数。一个协程可以在某个执行点挂起并在之后从挂起点恢复。与子函数不同的是，协程不需要在它返回前完成整个执行过程。

一个比较简单的例子如下所示：

(define one
   (lambda (go)
      (display 1)
      (set! go (call/cc go))
      (display 2)
      (set! go (call/cc go))
      (display 3)
      (set! go (call/cc go))))

(define two
   (lambda (go)
      (display #\a)
      (set! go (call/cc go))
      (display #\b)
      (set! go (call/cc go))
      (display #\c)
      (set! go (call/cc go))))

调用 (one two) ，可以看到输出为 1a2b3c ，调用 (two one) 则是 a1b2c3 。

通过使用 call/cc，上面的程序实现了在两个过程中互相传递 current continuation。

(define (make-generator procedure)
  (define last-return values)
  (define last-value #f)
  (define (last-continuation _)
    (let ((result (procedure yield)))
      (last-return result)))

  (define (yield value)
    (call/cc (lambda (continuation)
               (set! last-continuation continuation)
               (set! last-value value)
               (last-return value))))

  (lambda args
    (call/cc (lambda (return)
               (set! last-return return)
               (if (null? args)
                   (last-continuation last-value)
                   (apply last-continuation args))))))

(define fib-gen
   (make-generator
      (lambda (collect)
         (let f ([a 0] [b 1])
            (collect a)
            (f b (+ a b))))))

call/cc 配合宏使用，可以在 scheme 中添加一些自定义的控制结构。

这里的例子来自 the scheme Programming Language ，使用 syntax-case 宏定义了一个循环结构：

(define-syntax loop
   (lambda (x)
     (syntax-case x ()
       [(k e ...)
         (with-syntax ([break (datum->syntax #'k 'break)])
            #'(call/cc
               (lambda (break)
                 (let f () e ... (f)))))])))

当然，上面的代码重点在于 call/cc 的使用而不是 syntax-case 的使用。上面的代码添加了 break 语句，可以直接退出循环。下面的例子可以说明这一点：

(let ([n 3] [ls '()])
 (loop
    (if (= n 0) (break ls))
        (set! ls (cons 'a ls))
    (set! n (- n 1))))

输出结果为 3 个 a，即 aaa 。

有关 multitasking 的内容，可以参看 the Scheme Programming Language 的 engine 部分，这里就不介绍了。

使用斐波拉契函数作为 CPS 例子有两个好处：第一，它足够简单；第二，它不是太简单。

根据斐波拉契数列的数学定义，可以直接写出 fib 过程：

(define fib
   (lambda (n)
      (cond
         ((< n 0) #f)
         ((= n 0) 0)
         ((= n 1) 1)
         (else (+ (fib (- n 1))
                  (fib (- n 2)))))))

当然，我们可以把递归形式改成迭代形式，但是这并不是我们的重点。问题在于怎么把它改成 CPS。这里不考虑初等过程的 CPS，则 fib 的 CPS 可以写成：

(define fib-cps
  (lambda (n k)
    (cond
     ((< n 0) (k #f))
     ((= n 0) (k 0))
     ((= n 1) (k 1))
     (else
      (fib-cps (- n 1)
           (lambda (n1)
              (fib-cps (- n 2) (lambda (n2) (k (+ n1 n2))))))))))

除此之外，还可以这么写：

(define fib-cps2
  (lambda (n k)
    (cond
     ((< n 0) (k #f #f))
     ((= n 0) (k 0 0))
     ((= n 1) (k 1 0))
     ((= n 2) (k 1 0))
     (else
      (fib-cps2 (- n 1)
         (lambda (n1 n2)
             (fib-cps2 (- n 2)
                 (lambda (n3 n4)(k (+ n1 n2) (+ n3 n4))))))))))

玩了这么久的 call/cc，不知道你有没有想过将它应用于自身是什么结果。在 chez-scheme 的 REPL 中输入 (call/cc call/cc) ，你会得到 #<system continuation in new-cafe> 。在 racket 中输入 (call/cc call/cc) ，你会得到 #<continuation> 。不管怎么说，结果还是个 continuation。参考资料【3】给出了对它的分析。我在这里简单地说明一下。

将 (call/cc call/cc) 记作 a@(call/cc1 call/cc2) ，即使用 a 作为整个表达式的标识符，同时使用 1 和 2 对两个 call/cc 进行区分。

将 call/cc1 应用于 call/cc2，上面的表达式就变成了 a@(call/cc2 k@a) ，也就是使用 a 的 continuation 来作为 call/cc2 的参数。

再次变换，就得到了 a@(k@a k@a) ，这里的前一个 k@a是 call/cc1捕获的，后一个 k@a是 call/cc2 捕获的。这个表达式的值是显而易见的：continuation 调用 continuation，得到的还是 continuation。也就是说，最终结果就是 k@a 。

可以使用 ((call/cc call/cc) (lambda(x) 1)) 来验证结果的正确性，在 REPL 中输入这串代码，得到的结果应该为 1。

也就是说 (call/cc call/cc) 和之前提到过的 (call/cc (lambda (x) x)) 是等价的。 (call/cc call/cc) 等价于 (lambda(f) (f f)) 。

比较有意思的一点是，这样的构造是幂等的，也就是说， (call/cc call/cc) 和 ((call/cc call/cc) call/cc) 是一样的， (call/cc (call/cc call/cc)) 也可以。一直构造下去没有任何问题。

已知 Y combinator 的写法是：

(define (Y f)
  ((lambda (x)
     (lambda (n) ((f (x x)) n)))
   (lambda (x)
     (lambda (n) ((f (x x)) n)))))

使用 call/cc 就可以改写为：

(define (Y f)
  ((lambda (u)
     (u (lambda (x)
      (lambda (n) ((f (u x)) n)))))
   (call/cc (call/cc (lambda (x) x)))))

或：

(define (Y f)
  ((lambda (u)
     (u (lambda (x)
      (lambda (n) ((f (u x)) n)))))
   (call/cc call/cc)))

但是， ((call/cc call/cc) (call/cc call/cc)) 却是一个死循环。

上式可以写作 (a@(call/cc call/cc) b@(call/cc call/cc)) ，变换后的结果为：

(k@a k@b) ，a 的 continuation 是接受一个参数来作为 a@(call/cc call/cc) 过程的参数，b 的 continuation 是作为 a@(call/cc call/cc) 的参数。进一步变换后得到：

(k@b k@b) ，这也就是为什么死循环的原因吧。

通过以下的代码：

(let* ((yin
        ((lambda (cc) (display #\@) cc)
         (call/cc (lambda (c) c))))
       (yang
        ((lambda (cc) (display #\*) cc)
         (call/cc (lambda (c) c)))))
  (yin yang))

可以得到一个死循环程序，程序的输出还非常有规律 @*@**@***@****@*****@******@*******@********@********* 。

参考【13】，我们可以一步一步地推出整个式子的来龙去脉。

首先，yin 和 yang 分别与它们的 continuation 绑定，输出 @* 。这里，我们将 yin 和 yang 绑定的 continuation 分别记为 C1, C2。

随后，调用表达式 (yin yang) ，yin 的绑定值变为 yang 的绑定值 C2，并输出 @ ，yang 的绑定值更新为 C3，并输出 * 。需要注意的是，C3 与 C2 是不同的。

之后再次调用 (yin yang) ，yin 的值为 C2，所以此时跳跃到的地方不是 yin 的绑定过程，而是 yang 的绑定过程，yang 被绑定为 C3。因为没有经过 yin 的绑定过程，所以输出的只有 * 。此时你可能会认为 yin 是 C2 而 yang 是 C3，但事实并非如此，因为 yin 为 C2，所以 跳回的是 yin 为 C1，yang 为 C2 时的 point。正确的结果应该是 yin 为 C1，yang 为 C3。

接着调用 (yin yang) ，又回到了最初的绑定 point，yin 的值被赋为 C3，而 yang 的值更新为 C4，输出 @* 。

再次调用 (yin yang) ，yin 的值为 C3，回到 C3 处，输出 * ，yang 变为 C4，此时 yin 的值成为 C2（因为 yang 为 C3 时 yin 为 C2）。

下一次调用，yin 的值变为 C1，yang 的值变为 C4，输出 * 。（因为此时 yin 为 C2，所以回到 yang 为 C2 的 point，而 yang 为 C2 时 yin 为 C1）

…….

让我们看看现在输出了什么 @*@**@*** ，再继续下去当然没有问题，不过现在已经可以从中看出一些规律出来了，列一张表来观察随着 (yin yang) 调用 yin 和 yang 的值的变化。

1. 调用 0 次。yin：C1，yang：C2。输出 @*
2. 调用 1 次。yin：C2，yang：C3。输出 @*
3. 调用 2 次。yin：C1，yang：C3。输出 *
4. 调用 3 次。yin：C3，yang：C4。输出 @*
5. 调用 4 次。yin：C2，yang：C4。输出 *
6. 调用 5 次。yin：C1，yang：C4。输出 *
7. …….

规律已经很明显了，由 yin 所在的赋值表达式的 call/cc 只调用了 1 次，也就是产生了 C1。而 yang 处的 call/cc 随调用次数增多不断变大，使得回到 C1 的所需的调用次数也不断增多，从而出现了上面的输出效果。

关于这个结论的证明可以参考【13】。