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

SRFI 149 は syntax-rules のパターン言語のテンプレートに新しい機能を追加しています。 従来のテンプレートは、 サブテンプレートにつけることができる省略記号は 1 つだけだったのを、 2 つ以上も許し、 2 つ以上のときは余分な省略記号の分、 リストの append を繰り返す式を生成します。

(let-syntax ((syn-append
              (syntax-rules ()
               ((syn-append (a ...) ...)
                (list a ... ...)))))
 (syn-append (1 2 3) (4) (5 6))) ; =(expand)=> (list 1 2 3 4 5 6)

この機能のために、 構文オブジェクトを so-unwrap-syntax しつつリストを連結する補助手続きを使うことにします。

; (define (so-append . a) (so-vaappend a))
(define (so-vaappend a)
 (define (so-append2 lis1 lis2)
  (let rec ((a lis1))
   (cond
    ((so-null? a) lis2)
    ((so-pair? a) (cons (so-car a) (rec (so-cdr a))))
    (else (error "improper list not allowed" (so-strip-syntax lis1))))))
 (let rec ((a a))
  (cond
   ((so-null? a) '())
   ((so-null? (so-cdr a)) (so-car a))
   (else (so-append2 (so-car a) (rec (so-cdr a)))))))

さらに、 ベクタのために so-unwrap-syntax 版の手続きを定義します。

(define (so-vector? x) (vector? (so-unwrap-syntax x)))
(define (so-vector->list x) (vector->list (so-unwrap-syntax x)))

テンプレートからの変換は、 sytanx-error と、 省略記号エスケープ・テンプレート、 それ以外の 3 種類に分けます。 テンプレート要素から変換した式は、 リストを組み立てる式であり、 syntax-error は組み立て後のリストでエラーを発する式に変換します。 省略記号エスケープ・テンプレートは省略記号を指定せずに式を組み立てます。 それ以外のときは、 組み立て後のリストを変換手続きの値として返せば良いので、 変換した式をそのまま利用します。

;@<テンプレートを変換します@>=
  (define (conv-template var src k)
   (if (if (so-pair? src) (so-free-identifier=? (so-car src) _syntax-error) #f)
    (tmpl-element var (so-cdr src) dooot 0 (lambda (expr)
     (k (list 'apply 'error (list 'so-strip-syntax expr)))))
   (if (ellipsis-escape? dooot src)
    (tmpl-element var (so-cadr src) #f 0 k)
    (tmpl-element var src dooot 0 k))))

;@<省略記号エスケープ・テンプレートかどうか調べます@>
;@<テンプレート要素を変換します@>
;@<識別子テンプレートを変換します@>
;@<ペア・テンプレートを変換します@>
;@<サブテンプレートを変換します@>
;@<繰り返しパターン変数リストを抽出します@>
;@<式同士を append します@>
;@<式同士を cons します@>

省略記号エスケープ・テンプレートは、 省略記号で始まるリストの cadr 部です。

;@<省略記号エスケープ・テンプレートかどうか調べます@>=
  (define (ellipsis-escape? dooot src)
   (if (so-identifier? dooot) (if (so-pair? src) (if (so-pair? (so-cdr src))
   (if (so-null? (so-cddr src))
   (so-free-identifier=? (so-car src) dooot) #f) #f) #f) #f))

パターンの変換で作成したパターン変数の連想リスト var を使ってテンプレート要素を変換します。 dooot は識別子か偽のいずれかで、 識別子のときは省略記号の意味をもち、 偽のときは省略記号がエスケープされていることを表します。 rank は省略記号の段数です。 rank の初期値はゼロです。 ベクタはリストにしてからテンプレートから式に変換します。 使用時に、 その式で組み立てた結果はリストなので、 ベクタへ変換する式で包んでおきます。

;@<テンプレート要素を変換します@>=
  (define (tmpl-element var src dooot rank k)
   (if (so-null? src) (k ''())
   (if (so-identifier? src) (tmpl-identifier var src dooot rank k)
   (if (so-pair? src) (tmpl-pair var src dooot rank k)
   (if (so-vector? src)
    (tmpl-element var (so-vector->list src) dooot rank (lambda (expr)
     (k (list 'list->vector expr))))
    (k (list _quote src)))))))

識別子テンプレートの場合、 識別子がパターン変数の場合とそれ以外の場合に分かれます。 パターン変換が作った連想リストに登録されているものがパターン変数です。 パターン変数はそのままリストの組み立て式に置きます。 パターンでのリスト段数とテンプレートのリスト段数を比較しており、 パターンで省略記号を付けたパターン変数を、 テンプレートで省略記号なしで使えないよう制限しています。 パターン変数でない識別子はリテラルです。 syntax-quote 構文にして組立式に置きます。 ただしリテラルが省略記号のときは syntax-rules の構文エラーとします。

;@<識別子テンプレートを変換します@>=
  (define (tmpl-identifier var src dooot rank k)
   ((lambda (e)
     (if e
      (if (<= (cadr e) rank)
       (k src)
       (error "too few ellipsis" (so-strip-syntax rules)))
     (if (so-free-identifier=? src dooot)
      (error "invalid syntax-rules" (so-strip-syntax rules))
      (k (list 'so-env-rename-syntax 'd (list 'syntax-quote src))))))
    (find (lambda (x) (so-free-identifier=? (car x) src)) var)))

ペア・テンプレートの場合は、 car が省略記号エスケープ・テンプレートのとき、 サブテンプレートのとき、 それ以外のときの 3 種類があります。

;@<ペア・テンプレートを変換します@>=
  (define (tmpl-pair var src dooot rank k)
   (if (ellipsis-escape? dooot (so-car src))
    (tmpl-element var (so-cadr (so-car src)) #f rank (lambda (expr1)
     (tmpl-element var (so-cdr src) dooot rank (lambda (expr2)
      (k (tmpl-cons expr1 expr2))))))
   (if (ellipsis? dooot src)
    (tmpl-ellipsis var src dooot rank k)
    (tmpl-element var (so-car src) dooot rank (lambda (expr1)
     (tmpl-element var (so-cdr src) dooot rank (lambda (expr2)
      (k (tmpl-cons expr1 expr2)))))))))

サブテンプレートの後に続く省略記号の個数を loop-dooot で stretch に求めておいてから、 サブテンプレートの変換をおこないます。 サブテンプレートは tmpl-var で繰り返しパターン変数のリストを抜き出します。 これを使って so-map する式を生成します。 stretch が 1 を越えるときは、 so-vaappend の摘要を生成します。

;@<サブテンプレートを変換します@>=
  (define (tmpl-ellipsis var src dooot rank k)
   (define (loop-dooot src-tail stretch)
    (if (ellipsis? dooot src-tail)
     (loop-dooot (so-cdr src-tail) (+ stretch 1))
     (sub-tmpl (tmpl-var var (so-car src) (+ stretch rank) '()) src-tail stretch)))

   (define (sub-tmpl v src-tail stretch)
    (if (pair? v)
     (tmpl-element var (so-car src) dooot (+ stretch rank) (lambda (expr1)
      (tmpl-element var (so-cdr src-tail) dooot rank (lambda (expr2)
       (k (if (if (= stretch 1) (so-identifier? expr1) #f)
           (tmpl-append expr1 expr2)
           (tmpl-stretch stretch (cons* 'so-map (list 'lambda v expr1) v) expr2)))))))
     (error "too many ellipsis" (so-strip-syntax rules))))

   (define (tmpl-stretch stretch expr1 expr2)
    (if (<= stretch 1)
     (tmpl-append expr1 expr2)
     (tmpl-stretch (- stretch 1) (list 'so-vaappend expr1) expr2)))

  (loop-dooot src 0))

繰り返しパターン変数のリストは、 サブテンプレート中のパターン変数を抜き出します。 そのとき、 パターン中でのリスト段数とテンプレート中での段数を比較して抜き出すかどうかを rank-v で決めます。 パターン中でのリスト段数が不足しているものは抜き出しません。

;@<繰り返しパターン変数リストを抽出します@>=
  (define (tmpl-var var src rank v)
   (define (rank-v b v)
    (if (if b (>= (cadr b) rank) #f) (cons (car b) v) v))

   (if (so-pair? src)
    (tmpl-var var (so-car src) rank (tmpl-var var (so-cdr src) rank v))
   (if (if (so-identifier? src) (not (find (lambda (x) (so-bound-identifier=? x src)) v)) #f)
     (rank-v (so-assoc src var so-bound-identifier=?) v)
     v)))

append で組み立てる式を生成します。

;@<式同士を append します@>=
  (define (tmpl-append expr1 expr2)
   (if (equal? expr2 ''()) expr1
   (if (equal? expr1 ''()) expr2
   (if (if (pair? expr2) (eq? 'append (car expr2)) #f) (cons* 'append expr1 (cdr expr2))
    (list 'append expr1 expr2)))))

cons で組み立てる式を生成します。 空リストに cons していくときは list を使い、 そうでないときは cons* を使います。

;@<式同士を cons します@>=
  (define (tmpl-cons expr1 expr2)
   (if (equal? expr2 ''()) (list 'list expr1)
   (if (if (pair? expr2) (eq? 'list (car expr2)) #f) (cons* 'list expr1 (cdr expr2))
   (if (if (pair? expr2) (eq? 'cons* (car expr2)) #f) (cons* 'cons* expr1 (cdr expr2))
    (list 'cons* expr1 expr2)))))

これで、 syntax-rules マクロを低レベル・マクロへ変換する、 syntax-rules 構文を処理する変換手続きができました。

syntax-rules を構文環境に組み込む準備が整いました。

(define (so-rules-syntactic-environment)
 (let ((syntactic-env (so-core-syntactic-environment)))
  (so-define-syntax 'syntax-rules so-syntax-rules syntactic-env)
  (so-define-syntax 'let
   '(syntax-rules ()
     ((let ((x a) ...) e1 e2 ...)
      ((lambda (x ...) e1 e2 ...) a ...)))
   syntactic-env)
  (so-reset-unique-id-counter)
  syntactic-env))

いつもの or 構文の展開例です。

(define (demo)
 (let ((syntactic-env (so-rules-syntactic-environment)))
  (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))
    syntactic-env)))