健全なマクロ展開 - syntax-rules (その 4)

syntax-rules のパターンの省略記号は、 R6RS 以後、 正規リストとドッテッド・リストの両方の途中に導出可能になっています。 SRFI 149 の参考実装に採用している Chibi Scheme のものでは、 パターンの途中に省略記号があると、 パターンと比較対象式の両方を作り直して省略記号をリストの末尾へ移動してから、 パターン・マッチングを続ける作りになっています。 それに対して、 ここでは split-at-right 手続きを使ってリストの作り直しなしでマッチングしてきました。 さらに進んで、 この手続きの内部ループをパターン・マッチング部に埋め込んでみます。

Gist so-rules.scm

おおまかには、 参考実装のリストの作り替え部を削除し、 リストのマッチング部をペアを辿る回数で繰り返すように書き直します。

生成式の例として、 次のように b ... の後に 2 つペアが並んでいるとき、 パターン・マッチング式へ変換してみます。 まずパターン b ... に対応する被照合式 expr の開始ペアへ変数 w を束縛します。 続いて、 リストのペア数を求めて、 省略記号の後ろにあるペア数 2 を引いた数に変数 c を束縛します。 この後は、 変数 c の値がゼロより大きいときにループを繰り返します。 変数 c がゼロになったとき、 ループを終了し、 蓄積変数 v をひっくり返したリストにパターン変数 b を束縛します。 実際には、 ループが何重に入れ子になっても対応可能にするため、 作業変数をシリアル番号付きで生成し、 syntax-rules 自体の定義時構文環境で rename したものをマクロ変換で使います。 c と d のマッチング部分を省略部分に生成し、 テンプレートの作成部をさらにその内側に埋め込みます。

; パターン (_ a b ... c d) の b ... 部の低レベル・マクロへの変換結果例
     (let ((w (so-syntax-cddr expr)))
      (let lp ((c (- (so-syntax-length* w) 2)) (w w) (v '()))
       (and (>= c 0)
        (if (> c 0)
         (let ((b (so-syntax-car w)))
          (lp (- c 1) (so-syntax-cdr w) (cons b v)))
         (let ((b (reverse v)))
          (and (so-syntax-pair? w) 省略))))))

必要な補助手続きは so-syntax-length* と so-syntax-vaappend の 2 つです。 これらは前のものをそのまま利用します。 so-syntax-split-at-right 等は生成するコードに組み込んでしまうので不要です。 so-syntax-rules-macros 手続きが、 syntax-rules マクロ expr から低レベル・マクロへ変換します。 構文オブジェクトな展開器用に書いており、 マクロ変換手続きから、 この手続きを呼ぶときにテンプレート識別子 id を渡します。 識別子 id の構文情報をシンボルにくっつける rename 内部手続き等を揃えておきます。

(define (so-syntax-length* x) 省略)
(define (so-syntax-vaappend x) 省略)

; (syntax-rules () (pat1 tmpl1) (pat2 tmpl2) ...)
; を
; (lambda (expr)
;  (cdr
;   (or (<pat1からの変換構文> (cons #t <tmpl1からの変換式>))
;       (<pat2からの変換構文> (cons #t <tmpl2からの変換式>))
;       ...
;       (error "no matching" (so-syntax->datum expr)))))
; のように変換します。
(define (so-syntax-rules-macro expr id)
 (define (rename x) (so-datum->syntax id x))
 (define compare so-free-identifier=?)
 (define (croak . x) (apply error (append x (list (so-syntax->datum expr)))))
 (define count 0)
 (define (gen-var s)
  (set! count (+ count 1))
  (string->symbol (string-append s (number->string count))))

;@<expand-rules@>
;@<expand-heading@>
;@<expand-pattern@>
;@<expand-template@>
;@<ellipsis? 類@>
;@<ellipsis-depth 類@>
;@<all-vars@>
;@<free-vars@>

 `(,(rename 'lambda) (,(rename 'expr)) (,(rename 'cdr) ,(expand-rules expr))))

expand-rules は syntax-rules マクロから、 パターンとテンプレートの組を低レベル・マクロへ変換していきます。 そして、 それぞれの組からの変換結果を or 構文に並べます。 その際、 テンプレートからの生成結果が偽のときに備えて、 ダミーのペアを追加する式に変換します。 このダミー・ペアを削除するために、 上のように生成結果の cdr を取る式に変換します。 なお、 ここでは or 構文から let 構文と if 構文に展開した式に直接変換しています。

;@<expand-rules@>=
 (define (expand-rules src)
  (expand-heading src (lambda (dooot lits src)
   (let rec ((src src))
    (cond
     ((so-syntax-match? src '((pattern template) . _))
      (let ((pattern (so-syntax-car (so-syntax-car src)))
            (template (so-syntax-cadr (so-syntax-car src)))
            (t (rename (gen-var "t"))))
       `(,(rename 'let) ((,t ,(expand-pattern dooot lits pattern template)))
         (,(rename 'if) ,t ,t ,(rec (so-syntax-cdr src))))))
     ((so-syntax-null? src)
      `(,(rename 'error) "no matching" (,(rename 'so-syntax->datum) ,(rename 'expr))))
     (error (croak "invalid syntax-rules")))))))

expand-heading は syntax-rules マクロの先頭から省略記号とリテラル・リストを求めます。 リテラル・リストは全要素が識別子であることを確認した上で、 so-unwrap-syntax したリストに作り直します。

;@<expand-heading@>=
 (define (expand-heading src k)
  (if (so-syntax-match? src '(_ _ . _))
   (if (and (so-identifier? (so-syntax-cadr src)) (so-syntax-pair? (so-syntax-cddr src)))
    (k (so-syntax-cadr src) (check-lits (so-syntax-caddr src)) (so-syntax-cdddr src))
    (k (rename '...) (check-lits (so-syntax-cadr src)) (so-syntax-cddr src)))
   (croak "invalid syntax-rules")))

 (define (check-lits src)
  (let loop ((r '()) (x src))
   (cond
    ((and (so-syntax-pair? x) (so-identifier? (so-syntax-car x)))
     (loop (cons (so-syntax-car x) r) (so-syntax-cdr x)))
    ((so-syntax-null? x) (reverse r))
    (else (croak "invalid syntax-rules literal list")))))

expand-pattern はパターンとテンプレートの組を低レベル・マクロの式に変換します。 テンプレートの変換を組み込んであるのは、 パターン照合の構文の中に埋め込む形式になるためです。 そのため、 継続渡しスタイルの内部手続き conv を使います。 conv の引数は、 パターン p、 展開対象式の p に該当する部分を得る式 x、 リストの深さ dim、 パターン変数の連想リスト vars、 そして継続 k です。 vars はパターン変数の識別子と dim を連想対にしています。 継続 k は vars を引数に受け取り、 変換結果の式を返します。

パターンが識別子のときの変換処理は参考実装と同じです。 リテラル・リストのときは識別子が同じ意味かどうか調べる式に変換し、 そうでないときは let 構文でパターン変数を値に束縛する式に変換します。 パターン変数の重複チェックを省いているのは参考実装がそうなっていたためですけど、 チェックした方が安全でしょう。

省略記号のときは、 ペアの個数分ループする let 構文に変換します。ループしつつ、 サブパターン中のパターン変数のリストを作る式へ変換します。 そのための作業変数のリストが lis-vars です。 ループを終えた後は残りのパターンによるチェックを続けるよう変換します。 参考実装と比べると、 あちらではペアである限りループする let 構文に変換していました。 そのため、 ペアの個数に応じたパターン・マッチングができず、 前処理としてパターンを作り直し、 展開対象式を作り直す式へ変換していました。 今回はペアの個数でループする式に変換するので前処理は不要です。 その代わり、 ループを終えてから残りのパターンを照合する式への変換が必要になります。

ペアは、 ペアであるかを調べ、 car と cdr をそれぞれ照合する式に変換します。 ベクタは、 リストに変換してから照合する式に変換します。 それ以外は一致比較に変換します。

なお、 and 構文と let 構文を利用しており、 これらが低レベル・マクロで展開できるようになっていることを前提にしています。 let 構文はラベル付きのものも展開できなければなりません。

;@<expand-pattern@>=
 (define (expand-pattern dooot lits pat tmpl)
  (let conv ((p (so-syntax-cdr pat))
             (x `(,(rename 'so-syntax-cdr) ,(rename 'expr)))
             (dim 0)
             (vars '())
             (k (lambda (vars) `(,(rename 'cons) #t ,(expand-template dooot tmpl vars)))))
   (cond
    ((so-identifier? p)
     (if (find (lambda (u) (compare p u)) lits)
      `(,(rename 'and)
         (,(rename 'so-free-identifier=?) ,x (,(rename 'syntax-quote) ,p)) ,(k vars))
      `(,(rename 'let) ((,p ,x)) ,(k (cons (cons p dim) vars)))))
    ((ellipsis? dooot p)
     (if (find (lambda (x) (compare x dooot)) (so-syntax-cddr p))
      (croak "multiple ellipsises"))
     (let ((w (rename (gen-var "w")))
           (lp (rename (gen-var "lp")))
           (c (rename (gen-var "c")))
           (i (so-syntax-length* (so-syntax-cddr p)))
           (new-vars (all-vars (so-syntax-car p) dooot lits (+ dim 1))))
     (let ((lis-vars (map (lambda (x) (rename (gen-var "v"))) new-vars)))
      `(,(rename 'let) ((,w ,x))
        (,(rename 'let) ,lp ((,c (,(rename '-) (,(rename 'so-syntax-length*) ,w) ,i))
                             (,w ,w)
                             ,@(map (lambda (x) `(,x (,(rename 'quote) ()))) lis-vars))
         (,(rename 'and) (,(rename '>=) ,c 0)
          (,(rename 'if) (,(rename '>) ,c 0)
           ,(conv (so-syntax-car p) `(,(rename 'so-syntax-car) ,w) (+ dim 1) '() (lambda (_)
            `(,lp (,(rename '-) ,c 1) (,(rename 'so-syntax-cdr) ,w)
              ,@(map (lambda (x v) `(,(rename 'cons) ,(car x) ,v)) new-vars lis-vars))))
           (,(rename 'let) ,(map (lambda (x v) `(,(car x) (,(rename 'reverse) ,v))) new-vars lis-vars)
            ,(conv (so-syntax-cddr p) w dim (append new-vars vars) k)))))))))
    ((so-syntax-pair? p)
     `(,(rename 'and) (,(rename 'so-syntax-pair?) ,x)
       ,(conv (so-syntax-car p) `(,(rename 'so-syntax-car) ,x) dim vars (lambda (vars)
         (conv (so-syntax-cdr p) `(,(rename 'so-syntax-cdr) ,x) dim vars k)))))
    ((so-syntax-vector? p)
     `(,(rename 'and) (,(rename 'so-syntax-vector?) ,x)
       ,(conv (so-syntax-vector->list p) `(,(rename 'so-syntax-vector->list) ,x) dim vars k)))
    ((so-syntax-null? p) `(,(rename 'and) (,(rename 'so-syntax-null?) ,x) ,(k vars)))
    (else `(,(rename 'and) (,(rename 'equal?) ,x ,p) ,(k vars))))))

テンプレートの変換は一つを除いて参考実装と同じです。 参考実装の省略記号エスケープ部分は、 クォートとして変換していますが、 R7RS の仕様によると、 省略記号の意味をもつ識別子がないものとしてテンプレート処理をすることとなっているので、 ここでは仕様に合わせて書き直しました。 なお、 リストを扱うとき、 map と append を使うように変換しているので、 パターン処理部でパターン変数にリストを切り出す際には、 必ず cons して構文情報を car に押し込んでおかないといけません。 パターン処理部で変数 ... 形式をショートカットせずに、 それもループ処理の対象にしているのは、 必ず cons させるためです。

SRFI 149 のサブテンプレートに省略記号を 2 個以上並べることでリストをアペンドするギミックに対応している箇所は、 記号の個数を求める ellipsis-depth と、 それでリストの深さを補正する部分、 さらに do 構文でアペンドする式に変換している部分です。 ここでは、 構文オブジェクトをアペンドできるようにするため、 append 手続きではなく、 so-syntax-vaappend 手続きを使うように変換します。

;@<expand-template@>=
 (define (expand-template dooot tmpl vars)
  (define (conv t dooot dim)
   (cond
    ((so-identifier? t)
     (cond
      ((find (lambda (v) (compare t (car v))) vars) => (lambda (cell)
       (if (<= (cdr cell) dim)
        t
        (croak "too few ellipsises"))))
      (else `(,(rename 'syntax-quote) ,t))))
    ((so-syntax-pair? t)
     (cond
      ((ellipsis-escape? dooot (so-syntax-car t))
       `(,(rename 'cons) ,(conv (so-syntax-cadr (so-syntax-car t)) #f dim)
                         ,(conv (so-syntax-cdr t) dooot dim)))
      ((ellipsis? dooot t)
       (let* ((depth (ellipsis-depth dooot t))
              (ell-dim (+ dim depth))
              (ell-vars (free-vars (so-syntax-car t) vars ell-dim)))
        (cond
         ((null? ell-vars) (croak "too many ellipsises"))
         ((and (so-syntax-null? (so-syntax-cddr t)) (so-identifier? (so-syntax-car t)))
          (conv (so-syntax-car t) dooot ell-dim))
         (else
          (let* ((once (conv (so-syntax-car t) dooot ell-dim))
                 (nest `(,(rename 'map) (,(rename 'lambda) ,ell-vars ,once) ,@ell-vars))
                 (many (do ((d depth (- d 1))
                            (many nest `(,(rename 'so-syntax-vaappend) ,many)))
                           ((= d 1) many))))
          (if (so-syntax-null? (ellipsis-tail dooot t))
           many
           `(,(rename 'append) ,many ,(conv (ellipsis-tail dooot t) dooot dim))))))))
      (else `(,(rename 'cons) ,(conv (so-syntax-car t) dooot dim)
                              ,(conv (so-syntax-cdr t) dooot dim)))))
    ((so-syntax-vector? t) `(,(rename 'list->vector) ,(conv (so-syntax-vector->list t) dooot dim)))
    (else t)))

  (cond
   ((and (so-syntax-match? tmpl '(kw . _)) (compare (rename 'syntax-error) (so-syntax-car tmpl)))
    `(,(rename 'apply) ,(rename 'error) (,(rename 'so-syntax->datum) ,(conv (so-syntax-cdr tmpl) dooot 0))))
   ((ellipsis-escape? dooot tmpl) (conv tmpl #f 0))
   (else (conv tmpl dooot 0))))

省略記号に関わる述語は 2 つあります。 リストの途中に出現する省略記号を調べる ellipsis? と、 省略記号のエスケープ・テンプレートかどうかを調べる ellipsis-escape? です。

;@<ellipsis? 類@>=
 (define (ellipsis? dooot x)
  (and (so-identifier? dooot) (so-syntax-match? x '(_ kw . _)) (compare dooot (so-syntax-cadr x))))

 (define (ellipsis-escape? dooot x)
  (and (so-identifier? dooot) (so-syntax-match? x '(kw _)) (compare dooot (so-syntax-car x))))

SRFI 149 のテンプレートに 2 つ以上並んでも良い省略記号を扱う手続きも 2 つあります。 省略記号の個数を求める ellipsis-depth と、 省略記号の後続テンプレートを求める ellipsis-tail です。

;@<ellipsis-depth 類@>=
 (define (ellipsis-depth dooot x)
  (if (ellipsis? dooot x)
   (+ 1 (ellipsis-depth dooot (so-syntax-cdr x)))
   0))

 (define (ellipsis-tail dooot x)
  (if (ellipsis? dooot x)
   (ellipsis-tail dooot (so-syntax-cdr x))
   (so-syntax-cdr x)))

all-vars は、 サブパターンに含まれるパターン変数の連想リストを求めます。 パターン変数識別子とリストの深さの連想対になっています。 識別子のうち、 リテラルでないものが対象で、 入れ子になっているすべてのパターン変数をリストアップします。 それにより、 パターン変数を空リストに初期化できるようになっています。

;@<all-vars@>=
 (define (all-vars x dooot lits dim)
  (let rec ((x x) (dim dim) (vars '()))
   (cond
    ((so-identifier? x)
     (if (find (lambda (lit) (compare x lit)) lits)
      vars
      (cons (cons x dim) vars)))
    ((ellipsis? dooot x) (rec (so-syntax-car x) (+ dim 1) (rec (so-syntax-cddr x) dim vars)))
    ((so-syntax-pair? x) (rec (so-syntax-car x) dim (rec (so-syntax-cdr x) dim vars)))
    ((so-syntax-vector? x) (rec (so-syntax-vector->list x) dim vars))
    (else vars))))

free-vars は、 サブテンプレートに含まれるパターン変数のリストを求めます。 入れ子になっているサブテンプレートからも抜き出すのですけど、 抜き出す際に、 リストの入れ子を比較します。 リストの深さが dim 以上のものだけを抜き出すようになっています。

;@<free-vars@>=
 (define (free-vars x vars dim)
  (let rec ((x x) (free '()))
   (cond
    ((so-identifier? x)
     (cond
      ((find (lambda (v) (compare v x)) free) free)
      ((find (lambda (v) (compare (car v) x)) vars) => (lambda (cell)
       (if (>= (cdr cell) dim) (cons x free) free)))
      (else free)))
    ((so-syntax-pair? x) (rec (so-syntax-car x) (rec (so-syntax-cdr x) free)))
    ((so-syntax-vector? x) (rec (so-syntax-vector->list x) free))
    (else free))))

以上の syntax-rules マクロを構文オブジェクトな展開器に組み込むには、 低レベル・マクロで and 構文とラベル付き let 構文を展開できるようにしておきます。

(define (so-let-macro x id)
 (define (rename x) (so-datum->syntax id x))
 (cond
  ((and (so-syntax-match? x '(_ e . _)) (so-identifier? (so-syntax-cadr x))
        (so-let-validate (so-syntax-cdr x)))
   (let ((tag (so-syntax-cadr x))
         (vars (so-syntax-map so-syntax-car (so-syntax-caddr x)))
         (args (so-syntax-map so-syntax-cadr (so-syntax-caddr x)))
         (body (so-syntax-cdddr x)))
    `(((,(rename 'lambda) (,tag)
        (,(rename 'set!) ,tag (,(rename 'lambda) (,@vars) ,@body)) ,tag) #f) ,@args)))
  ((so-let-validate x)
   (let ((vars (so-syntax-map so-syntax-car (so-syntax-cadr x)))
         (args (so-syntax-map so-syntax-cadr (so-syntax-cadr x)))
         (body (so-syntax-cddr x)))
    `((,(rename 'lambda) (,@vars) ,@body) ,@args)))
  (else (error "no matching" (so-syntax-datum x)))))

(define (so-and-macro x id)
 (define (rename x) (so-datum->syntax id x))
 (cond
  ((so-syntax-match? x '(_)) #t)
  ((so-syntax-match? x '(_ e1)) (so-syntax-cadr x))
  ((so-syntax-match? x '(_ e1 e2 ...))
   (let ((e1 (so-syntax-cadr x)) (e2 (so-syntax-cddr x)))
    (if (eq? (so-unwrap-syntax e1) #t)
     `(,(rename 'and) ,@e2)
     `(,(rename 'if) ,e1 (,(rename 'and) ,@e2) #f))))
  (else (error "no matching" (so-syntax-datum x)))))

これらと合わせて、 syntax-rules マクロをテンプレート識別子に登録します。

(define (so-rules-syntax-object)
 (let ((id (so-core-syntax-object)))
  (so-define-syntax id 'let
   '(lambda (x) (so-let-macro x (syntax-quote let))))
  (so-define-syntax id 'and
   '(lambda (x) (so-and-macro x (syntax-quote and))))
  (so-define-syntax id 'syntax-rules
   '(lambda (x) (so-syntax-rules-macro x (syntax-quote syntax-rules))))
  (so-reset-unique-id-counter)
  id))

このテンプレート識別子で syntax-rules でマクロを定義して利用することができます。

(define (demo)
 (so-expand
  '(letrec-syntax
    ((or (syntax-rules ()
      ((or) #f)
      ((or e1) e1)
      ((or e1 e2 ...) (let ((t e1)) (if t t (or e2 ...)))))))
    ((lambda (x) (let ((if list) (t x)) (or 1 t))) 2))
  (so-rules-syntax-object)))