健全なマクロ展開 - 構文オブジェクト (その11)

syntax-case は、 シンボルに構文環境がくっついた識別子を使うことで健全性を実現します。 識別子を使って変換結果を作るのはマクロ変換子の役目で、 展開器が識別子に変換世代を区別する印を追加してくれます。 マクロ変換子が使う識別子はマクロの定義式から取り込んだもので、 定義式時点の構文環境が既にくっついています。 取り込んだ識別子をデータ扱いにしたいので、 識別子をクォートする構文で定義式を記述するのが普通です。 ところが、 健全なマクロ展開の quote 構文の約束ごとでは、 構文情報を削り落とすことになっています。 そのため、 マクロ定義用に構文情報を残すもう一つのクォート構文を使います。 R4RS の低レベル・マクロ仕様ではこの構文のキーワードを syntax にすると定めていました。 その後、 syntax-case が syntax 構文を拡張して変換結果を組み立てるテンプレートに使うようになりました。 それで、 クォート専用の構文が仕様からなくなってしまい、 この展開器では、 syntax-quote キーワードを割り当てました。 このキーワードは Chibi Scheme から取り入れたものです。

syntax-quote の使い方は quote と同じです。 その 10 の or 構文の変換結果の生成式が一例で、 識別子をクォートするときに quote を syntax-quote に変えていました。 とは言っても、 syntax-quote しておくために list 手続きで式を組み立てるのは煩わしいものです。 そこで、 展開状況説明のためにでっちあげた syntax-quasiquote 構文を使えるようにしてみます。 これは syntax-quote 構文でクォートする quasiquote の変種です。

; (syntax-quasiquote (let ((t ,e1)) (if t t (or ,e2))))
(list (syntax-quote let) (list (list (syntax-quote t) e1))
      (list (syntax-quote if) (syntax-quote t)
            (syntax-quote t)
            (cons (syntax-quote or) e2)))

ここでは、 手元に明示リネーミング・マクロ展開器用の quasiquote マクロがあったので、 流用して syntax-quasiquote マクロにします。 変換結果を識別子で作りさえすれば良いので、 rename をすげかえて、 シンボルから識別子を作るようにします。 compare は so-free-identifier=? に変えます。

(define (so-quasi-macro x kuasi kuote)
 (define (rename x) (so-datum->syntax kuasi x))
 (define compare so-free-identifier=?)
 (define (tag? tag x) (and (so-syntax-pair? x) (compare tag (so-syntax-car x))))
 (define (single? tag x) (and (tag? tag x) (so-syntax-match? x '(_ _))))
 (let qq ((x (so-syntax-cadr x)) (d 0))
  (cond
   ((so-identifier? x) (list kuote x))
   ((not (so-syntax-pair? x)) (list (rename 'quote) x))
   ((tag? kuasi x)
    (list (rename 'cons) (list kuote (so-syntax-car x)) (qq (so-syntax-cdr x) (+ d 1))))
   ((and (> d 0) (or (tag? (rename 'unquote) x) (tag? (rename 'unquote-splicing) x)))
    (list (rename 'cons) (list kuote (so-syntax-car x)) (qq (so-syntax-cdr x) (- d 1))))
   ((and (= d 0) (single? (rename 'unquote) x)) (so-syntax-cadr x))
   ((and (= d 0) (or (tag? (rename 'unquote) x) (tag? (rename 'unquote-splicing) x)))
    (error (so-syntax->datum kuasi) "illegal unquote/unquote-splicing"))
   ((and (= d 0) (single? (rename 'unquote-splicing) (so-syntax-car x))
                 (so-syntax-null? (so-syntax-cdr x)))
    (so-syntax-cadr (so-syntax-car x)))
   ((and (= d 0) (tag? (rename 'unquote) (so-syntax-car x)))
    (so-syntax-fold-right (lambda (e r) (list (rename 'cons) e r))
     (qq (so-syntax-cdr x) d) (so-syntax-cdr (so-syntax-car x))))
   ((and (= d 0) (tag? (rename 'unquote-splicing) (so-syntax-car x)))
    (so-syntax-fold-right (lambda (e r) (list (rename 'append) e r))
     (qq (so-syntax-cdr x) d) (so-syntax-cdr (so-syntax-car x))))
   (else (list (rename 'cons) (qq (so-syntax-car x) d) (qq (so-syntax-cdr x) d))))))

上のマクロ変換手続きは、 通常の手続きとして、 マクロ定義の外に置いておきます。 そして、 マクロ定義からは、 syntax-quote した識別子を渡して、 マクロ変換をおこなうようにします。 ついでに、 これまでに合わせて、 let 構文も使えるようにしておきます。 この let 構文は、 syntax-quasiquote 構文を使って書いてあります。

(define (so-scheme-syntax-object)
 (let ((id (so-core-syntax-object)))
  (so-define-syntax id 'syntax-quasiquote
   '(lambda (x)
     (so-quasi-macro x (syntax-quote syntax-quasiquote) (syntax-quote syntax-quote))))

  (so-define-syntax id 'let
   '(lambda (x)
     (if (so-let-validate x)
      ((lambda (vars args body) 
        (syntax-quasiquote ((lambda (,@vars) ,@body) ,@args)))
       (so-syntax-map so-syntax-car (so-syntax-cadr x))
       (so-syntax-map so-syntax-cadr (so-syntax-cadr x))
       (so-syntax-cddr x))
      (error "invalid let" (so-syntax->datum x)))))

  (so-reset-unique-id-counter)
  id))

so-syntax-match? と syntax-quasiquote を使うだけでも、 多少手間を省いてマクロを記述できるようになります。 or 構文はこうなります。

(define (demo1)
 (so-expand
  '(letrec-syntax
    ((or (lambda (x)
      (if (so-syntax-match? x '(_)) #f
      (if (so-syntax-match? x '(_ e1)) (so-syntax-cadr x)
      (if (so-syntax-match? x '(_ e1 e2 ...))
       (let ((e1 (so-syntax-cadr x)) (e2 (so-syntax-cddr x)))
        (syntax-quasiquote (let ((t ,e1)) (if t t (or ,@e2)))))
      ;else
       (error "no matching" (so-syntax->datum x))))))))
    ((lambda (x) (let ((if list) (t x)) (or 1 t))) 2))
  (so-scheme-syntax-object)))

R4RS の cond の例です。

(define (demo2)
 (so-expand
  '(letrec-syntax
    ((cond (lambda (x)
      (if (so-syntax-match? x '(_ (e1 e2 e3)))
       (let ((e1 (so-syntax-car (so-syntax-cadr x)))
             (e2 (so-syntax-cadr (so-syntax-cadr x)))
             (e3 (so-syntax-caddr (so-syntax-cadr x))))
        (if (so-free-identifier=? e2 (syntax-quote =>))
         (syntax-quasiquote (let ((t ,e1)) (if t (,e3 t))))
         (syntax-quasiquote (if ,e1 (begin ,e2 ,e3)))))))))
    (let ((=> #f)) (cond (#t => 'ok))))
  (so-scheme-syntax-object)))

マクロの再帰定義の例です。

(define (demo3)
 (so-expand
  '(let-syntax
    ((freeid=? (lambda (x)
      (if (so-syntax-match? x '(_ a b))
       (let ((a (so-syntax-cadr x)) (b (so-syntax-caddr x)))
        (syntax-quasiquote
         (let-syntax
          ((test (lambda (y)
           (if (so-free-identifier=? (syntax-quote ,a) (so-syntax-cadr y)) #t #f))))
          (test ,b)))))))
     (foo? (lambda (x)
      (if (so-syntax-match? x '(_ tester a))
       (let ((tester (so-syntax-cadr x)) (a (so-syntax-caddr x)))
        (syntax-quasiquote (,tester foo ,a)))))))
    (list (freeid=? foo foo)
          (freeid=? foo bar)
          (let ((foo 1)) (freeid=? foo foo))
          (foo? freeid=? foo)
          (let ((foo 1)) (foo? freeid=? foo))))
  (so-scheme-syntax-object)))