CKスタイルマクロで途中脱出

ckcc.scm

#!r6rs
(import (rnrs))

;; From "Applicative syntax-rules: macros that compose better",
;; http://okmij.org/ftp/Scheme/macros.html#ck-macros
(define-syntax ck
  (syntax-rules (quote)
    ;; yield the value on empty stack
    ((ck () 'v) v)
    ;; re-focus on the other argument, ea
    ((ck (((op ...) ea ...) . s) 'v)
     (ck s "arg" (op ... 'v) ea ...))
    ;; all arguments are evaluated,
    ;; do the redex
    ((ck s "arg" (op va ...))
     (op s va ...))
    ;; optimization when the first ea
    ;; was already a value
    ((ck s "arg" (op ...) 'v ea1 ...)
     (ck s "arg" (op ... 'v) ea1 ...))
    ;; focus on ea, to evaluate it
    ((ck s "arg" (op ...) ea ea1 ...)
     (ck (((op ...) ea1 ...) . s) ea))
    ;; Focus: handle an application;
    ;; check if args are values
    ((ck s (op ea ...))
     (ck s "arg" (op) ea ...))
    ))

;; 自然数の和。ただし自然数 n を長さ n のリストで表す。以下同じ。
(define-syntax ck-add
  (syntax-rules (quote)
    ((_ s '() 'n)
     (ck s 'n))
    ((_ s '(_ . m) 'n)
     (ck s (ck-add 'm '(1 . n))))))

;; 自然数の積
(define-syntax ck-mul
  (syntax-rules (quote)
    ((_ s '() '_)
     (begin
       ;; ck-mul の呼び出し回数を確認するための debug print
       (display "mul!\n")
       (ck s '())))
    ((_ s '(_ . m) 'n)
     (ck s (ck-add 'n (ck-mul 'm 'n))))))

;; (ck-product '(x ...)) は x ... の総積を求める。
;; ただし x ... の中に 0 があれば即座に計算を打ち切って 0 を返す。
(define-syntax ck-product
  (syntax-rules (quote)
    ((_ s '_ '())
     (ck s '(1)))
    ((_ s 'exit '(() . __))
     (ck s (exit '())))
    ((_ s 'exit '(x . rest))
     (ck s (ck-mul 'x (ck-product 'exit 'rest))))
    ((_ s 'xs)
     ;; CK機械の状態は外側の評価文脈
     ;; (f1 v11 ... [] e11 ...), (f2 v21 ... [] e21 ...), ... を
     ;; 内側から順に並べたリスト。
     ;; ck マクロではこれを (((f1 v11 ...) e11 ...) ...) のような形で表す。
     ;; これは継続。
     (let-syntax ((f (syntax-rules (quote)
                       ((_ _s 'v)
                        (ck s 'v)))))
       (ck s (ck-product 'f 'xs))))))

;; 以下と同じ意味のつもり
(define product
  (let ((mul (lambda (x y)
               (display "mul!\n")
               (* x y))))
    (case-lambda
     ((xs)
      (call/cc
        (lambda (k)
          (product k xs))))
     ((exit xs)
      (cond
       ((null? xs)
        1)
       ((zero? (car xs))
        (exit 0))
       (else
        (mul (car xs) (product exit (cdr xs)))))))))

(define-syntax ck-quote
  (syntax-rules (quote)
    ((_ s 'x)
     (ck s ''x))))

(display (length (ck () (ck-quote (ck-product '((1 2) (1 2) () (1 2) (1 2)))))))
(newline)
(display (length (ck () (ck-quote (ck-product '((1 2) (1 2) (1 2) (1 2)))))))
(newline)

(display (product '(2 2 0 2 2)))
(newline)
(display (product '(2 2 2 2)))
(newline)