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

構文オブジェクト (その 3) 展開器で syntax-rules を使えるようにします。

今回の syntax-rules はそれ自身が低レベル・マクロです。 このマクロは syntax-rules 構文で記述してある展開対象式を低レベル・マクロの展開対象式へと変換します。 パターン言語を低レベル・マクロの式に変換し、 それをλ構文にします。 そのとき、 変換後の式が使う so-split-at-right* 手続きはメモ化してあり、マクロ変換の終わりでメモを消去してから終了するように、 手続きを組み立てます。 下線で始まるシンボルは、 すべてが syntax-rules 構文の定義時環境をくっつけたシンボルの別名で、 変換された低レベル・マクロの式を展開した後に、 シンボルの補足が生じないようにします。

(define (so-syntax-rules rules env defined-env)
;@<syntax-rules 構文のキーワードを識別子にします@>
;@<syntax-rules 構文のキーワードの同意比較をおこないます@>
;@<ユニークなシンボルを生成します@>

 (define (convert src)
  (conv-opt-dooot src (lambda (dooot src)
   (conv-literal src (lambda (literal? src)
    (conv-rule-list dooot literal? src (lambda (expr)
     (list 'lambda (list 'x 'e 'd)
      (list (list 'lambda (list 'x) (list 'so-take-right ''() 0) 'x) expr)))))))))

;@<省略記号の指定があるならそれを取り込みます@>
;@<リテラル・リストを取り込みます@>
;@<パターン言語を低レベル・マクロに変換します@>

 (convert rules))

syntax-rules 構文はいくつかのキーワードを使います。 パターンとテンプレートに含まれる識別子がキーワードの意味で使われているかどうか判定できるように、 キーワードを識別子にします。 識別子にくっつけている defined-env は syntax-rules 構文それ自身の定義時構文環境です。 通常、 syntax-rules 構文それ自身はトップレベルで定義するでしょうから、 quote はコアの特殊形式のキーワードの意味になっているはずです。

;@<syntax-rules 構文のキーワードを識別子にします@>=
 (define _any (so-extend-wrap defined-env '_))
 (define _dooot (so-extend-wrap defined-env '...))
 (define _quote (so-extend-wrap defined-env 'quote))
 (define _syntax-error (so-extend-wrap defined-env 'syntax-error))

キーワードの意味比較は syntax-rules それ自身の展開時構文環境でおこないます。

;@<syntax-rules 構文のキーワードの同意比較をおこいます@>=
 (define (so-free-identifier=? x y)
  (so-identifier=? env x env y))

パターン言語を変換したコードで使うためのシンボルを生成できるようにしておきます。 生成には、 前置詞を文字列で指定し、 それにシリアル番号を追加してシンボルにします。

;@<ユニークなシンボルを生成します@>=
 (define counter 0)

 (define (gen-var x)
  (set! counter (+ counter 1))
  (string->symbol (string-append x (number->string counter))))

ここから、 syntax-rules マクロから低レベル・マクロへの変換手続の詳細に潜ります。
syntax-rules マクロの先頭へ省略記号を指定し、 3 連ドット・シンボルではない識別子を使うことができます。 この指定はなくても良くて、 そのときは 3 連ドット・シンボルを省略記号とします。

;@<省略記号の指定があるならそれを取り込みます@>=
 (define (conv-opt-dooot src k)
  (if (if (so-pair? (so-cdr src)) (so-identifier? (so-cadr src)) #f)
   (k (so-cadr src) (so-cddr src))
   (k _dooot (so-cdr src))))

syntax-rules マクロで使うリテラルのリストを取り込みます。 このリストは構文オブジェクトなので、 so-map で識別子のリストに作り直します。 このリストは識別子がリテラルかどうかの判定にしか使用しないので、 意味比較の述語にします。

;@<リテラル・リストを取り込みます@>=
 (define (conv-literal src k)
  (define (pred-literal lit)
   (lambda (x) (find (lambda (y) (so-free-identifier=? x y)) lit)))

  (if (if (so-pair? src) (so-split-at-right* (so-car src) 0 (lambda (src1 src2)
       (if (so-every so-identifier? src1) (so-null? src2) #f))) #f)
   (k (pred-literal (so-map identity (so-car src))) (so-cdr src))
   (error "invalid syntax-rules" (so-strip-syntax rules))))

パターンとテンプレートの組をそれぞれ変換し、 if 構文を組み立てます。 この if 構文は or 構文に相当し、 先頭からパターンに合致するかどうかを順に調べ、 合致したらテンプレートで式を組み立てて返すふるまいをします。 どれにも一致しないときはエラーを生じます。 パターンを変換すると if 構文の条件式に使うための論理式 test と、 テンプレート摘要に使うためのパターン変数の値取得式の2つができあがります。 後者はパターン変数の連想リスト var になっています。 パターン変数は syntax-rules マクロの識別子のままλ構文の引数にはめ込みます。 λ構文の識別子の展開は展開器にまかせます。 テンプレートは expr に変換されて、 λ構文の本体式になります。 今回の実装は手を抜いてあって、 パターンとテンプレートの組がゼロであっても構文エラーにしません。 そのような syntax-rules マクロは使用時にエラーを生じます。 フェンダーは使えません。

;@<パターン・テンプレートの組のリストを変換します@>=
 (define (conv-rule-list dooot literal? src k)
  (define (conv-rule src k)
   (if (if (so-pair? src) (if (so-pair? (so-car src)) (if (so-pair? (so-cdr (so-car src)))
       (if (so-null? (so-cddr (so-car src))) (if (so-pair? (so-car (so-car src)))
       (so-identifier? (so-car (so-car (so-car src)))) #f) #f) #f) #f) #f)
     (conv-pattern (so-car (so-car src)) (lambda (test var)
      (conv-template var (so-cadr (so-car src)) (lambda (expr)
       (conv-rule (so-cdr src) (lambda (otherwise)
        (k (list 'if test
            (cons* (list 'lambda (map car var) expr) (map cddr var))
            otherwise))))))))
   (if (so-null? src)
    (k (list 'error "no matching" (list 'so-strip-syntax 'x)))
    (error "invalid syntax-rules" (so-strip-syntax rules)))))

;@<パターンを変換します@>
;@<テンプレートを変換します@>
;@<省略記号のついた要素かどうかを調べます@>

  (conv-rule src k))

パターンの変換は pat-element でおこないます。 この手続きは、 7 つの状態を継続渡しスタイルで状態遷移して変換を進めます。 状態 once は、 リストの一段階でまだ省略記号に出会ってないときに真になります。 これが偽のときは省略記号に既に出会ったことを表します。 省略記号はリストの一段階で 1 度しか利用できず、 once が偽のときに省略記号に出会うとエラーを発します。 状態 src は入力構文オブジェクトです。 状態 x は条件式のためのリストのアクセス摘要、 状態 g はパターン変数の値取得のためのリストのアクセス摘要です。 状態 rank は省略記号によるリストの深さです。 状態 test は組み立て中の条件式、 var は組み立て中のパターン変数の連想リストです。 継続渡しするのは条件式とパターン変数です。 ベクタはリストにしてパターン一致するかどうか調べます。

;@<パターンを変換します@>=
  (define (conv-pattern src k)
   (pat-element #t (cons _any (so-cdr src)) 'x 'x 0 #t '() k))

  (define (pat-element once src x g rank test var k)
   (if (simple? src) (k (pat-and (list 'equal? src x) test) var)
   (if (so-null? src) (k (pat-and (list 'so-null? x) test) var)
   (if (so-identifier? src) (pat-identifier src x g rank test var k)
   (if (so-pair? src) (pat-pair once src x g rank test var k)
   (if (so-vector? src)
     (pat-element #t (so-vector->list src) (list 'so-vector->list x)
       (list 'so-vector->list g) rank test var (lambda (test var)
      (k (pat-and (list 'so-vector? x) test) var)))
     (error "invalid syntax-rules pattern" (so-strip-syntax rules))))))))

;@<パターン識別子を変換します@>
;@<パターン・ペアを変換します@>
;@<単純要素か?@>
;@<条件式を and 結合で組み立てます@>

パターンが単純要素のときは、 equal? を条件式にします。 単純要素は、 論理値・数値・文字・文字列です。

;@<単純要素か?@>=
  (define (simple? x)
   (if (boolean? x) #t (if (number? x) #t (if (char? x) #t (string? x)))))

pat-and は条件式を and 結合で組み立てます。 この and 結合は論理値専用で、 and 構文のように let 構文で値を覚えません。

;@<条件式を and 結合で組み立てます@>=
  (define (pat-and test1 test2)
   (if (eq? test1 #t) test2
   (if (eq? test2 #t) test1
       (list 'if test1 test2 #f))))

パターン中の識別子は、 ワイルド・カードかリテラルかパターン変数のいずれかに分かれます。 ワイルド・カードのときは、 条件式もパターン変数も変化しません。 省略記号が識別子として現れたときは構文エラーにします。 リテラルは条件式に意味の一致判定を加えます。 パターン変数が既に登録してあったときは 2 重定義なのでエラーにします。 パターン変数は条件式を変化させず、 var に連想対を追加します。 パターン変数の連想対は、 パターン変数自身の識別子・リスト段数・値取得式の組です。 リスト段数はテンプレートへの変換時に使います。

;@<パターン識別子を変換します@>=
  (define (pat-identifier src x g rank test var k)
   (if (so-free-identifier=? src _any)
    (k test var)
   (if (so-free-identifier=? src _dooot)
    (error "invalid syntax-rules" (so-strip-syntax rules))
   (if (literal? src)
    (k (pat-and (list 'so-identifier=? 'e x 'd (list 'syntax-quote src)) test) var)
   (if (so-assoc src var so-bound-identifier=?)
    (error "duplicate pattern variable" (so-strip-syntax src))
    (k test (cons (cons* src rank g) var)))))))

パターン中のペアは、 car がクォート・パターンのとき、 リストの途中の省略記号付きサブパターンのとき、 それ以外のペアのときの 3 通りに分けます。 それ以外のペアでは、 car と cdr のパターンを変換した条件式の前に pair? 述語を追加します。

;@<パターン・ペアを変換します@>=
  (define (pat-pair once src x g rank test var k)
   (if (quote? (so-car src))
    (pat-element once (so-cdr src) (pat-cxr 'so-cdr x) (pat-cxr 'so-cdr g) rank test var (lambda (test var)
     (k (pat-and (list 'so-pair? x) (pat-and (pat-equal-quote src x) test)) var)))
   (if (ellipsis? dooot src)
    ((lambda (x1 x2 i)
      (pat-element #f (so-cddr src) x2 (pat-take-right src g i) rank #t var (lambda (test2 var2)
       (pat-element #t (so-car src) x1 x1 (+ rank 1) #t '() (lambda (test1 var1)
        (k (pat-and (pat-split-at-right x i x1 x2 test1 test2) test)
           (append (pat-var-map x1 (pat-drop-right src g i) var1) var2)))))))
     (gen-var "x")
     (gen-var "x")
     (so-length* (so-cddr src)))
    (pat-element once (so-cdr src) (pat-cxr 'so-cdr x) (pat-cxr 'so-cdr g) rank test var (lambda (test var)
     (pat-element #t (so-car src) (pat-cxr 'so-car x) (pat-cxr 'so-car g) rank test var (lambda (test var)
      (k (pat-and (list 'so-pair? x) test) var))))))))

;@<パターン cxr@>
;@<クォート・パターンか?@>
;@<クォート条件式@>
;@<so-take-right、so-drop-right、pat-split-at-right の生成@>
;@<サブパターンからパターン変数の値を取得する式を生成します@>

リストの要素アクセスは、 cdr cdr 等のときは cddr 等へまとめています。 低レベル・マクロに変換した結果の読みやすさを犠牲にしてかまわないなら、 この手続きは不要です。

;@<パターン cxr@>=
 (define cxr-table '((so-cdr   so-cadr   . so-cddr)
                     (so-cddr  so-caddr  . so-cdddr)
                     (so-cdddr so-cadddr . so-cddddr)))

  (define (pat-cxr f x)
   ((lambda (e)
     (if e (list (if (eq? f 'so-car) (cadr e) (cddr e)) (cadr x)) (list f x)))
    (if (pair? x) (assq (car x) cxr-table) #f)))

クォート・パターンはクォート構文と同じで、 リストの先頭のキーワードが quote の意味を持ち、 長さが 2 の正規リストかどうかを調べます。

;@<クォート・パターンか?@>=
  (define (quote? src)
   (if (so-pair? src) (if (so-free-identifier=? (so-car src) _quote)
   (if (so-pair? (so-cdr src)) (so-null? (so-cddr src)) #f) #f) #f))

クォート条件式は、 クォート構文に一致することを調べる式を生成します。 そのため、 クォート・パターンをさらにクォートしておきます。 マクロ変換時には、 展開対象式は構文オブジェクトになっているので、 so-strip-syntax してから一致判定する式を生成しておきます。

;@<クォート条件式@>=
  (define (pat-equal-quote src x)
   (list 'equal? (list _quote (so-car src)) (list 'so-strip-syntax (pat-cxr 'so-car x))))

省略記号付きのサブパターンなのかどうかを調べます。 この述語はテンプレートでも使います。 dooot が識別子かどうかチェックしているのは省略記号エスケープ・テンプレート用です。

;@<省略記号のついた要素かどうかを調べます@>=
  (define (ellipsis? dooot src)
   (if (so-identifier? dooot) (if (so-pair? src) (if (so-pair? (so-cdr src))
    (so-free-identifier=? (so-cadr src) dooot) #f) #f) #f))

省略記号付きのサブパターンの比較部分の切り出しのために、 so-take-right、 so-drop-right、pat-split-at-right 手続きを生成します。 pat-split-at-right は条件式生成で使います。 他はパターン変数の値取得式生成で使います。

;@<so-take-right、so-drop-right、pat-split-at-right の生成@>=
  (define (pat-take-right src g i)
   (if (if (so-null? (so-cddr src)) (= i 0) #f) g (list 'so-take-right g i)))

  (define (pat-drop-right src g i)
   (if (if (so-null? (so-cddr src)) (= i 0) #f) g (list 'so-drop-right g i)))

  (define (pat-split-at-right x i x1 x2 test1 test2)
   (if (if (eq? test1 #t) (eq? test2 #t) #f)
    #t
    (list 'so-split-at-right* x i (list 'lambda (list x1 x2)
     (pat-and (pat-every test1 x1) test2)))))

;@<so-every の生成@>

省略記号の繰り返し部のサブパターンをリストの要素全部が満たすかどうかを調べる条件式を so-every で生成します。

;@<so-every の生成@>=
  (define (pat-every test1 x1)
   (if (eq? test1 #t) test1 (list 'so-every (list 'lambda (list x1) test1) x1)))

省略記号の繰り返し部のサブパターンからパターン変数の値を取得する式を生成します。 サブパターンがパターン変数のときは全部を取り込み、 それ以外は so-map で欲しい部分を取り出したリストにします。

;@<サブパターンからパターン変数の値を取得する式を生成します@>=
  (define (pat-var-map x1 g v1)
   (define (accessor ap)
    (if (eq? ap x1)
     g
    (if (if (pair? ap) (eq? (cadr ap) x1) #f)
     (list 'so-map (car ap) g)
     (list 'so-map (list 'lambda (list x1) ap) g))))
   (map (lambda (e) (cons* (car e) (cadr e) (accessor (cddr e)))) v1))

次回、 テンプレートの変換に続く。