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

前回の syntax-rules マクロは、 Hanson-Bawden 構文クロージャ展開器で利用することを想定して作っています。

Gist rsc-rules.scm
Gist rsc-expand.scm

まず、 so-rules.scm から so-syntax-rules-macro をテキスト・ファイルに抜き出します。 そして、 テキスト・エディタで次のように文字列を一括置換します。 vi の ex モードを使うなら次のようにします。

1,$s/so-syntax-length/sc-length/g
1,$s/so-syntax->datum/sc-strip/g
1,$s/so-syntax-match/sc-match/g
1,$s/so-syntax-//g
1,$s/so-/sc-/g

sc-length* を追加します。

(define (sc-length* x)
 (if (not (pair? x))
  0
  (let loop ((x x) (xx (cdr x)) (c 1))
   (cond
    ((eq? x xx) (error "cyclic list"))
    ((and (pair? xx) (pair? (cdr xx))) (loop (cdr x) (cddr xx) (+ c 2)))
    (else (if (pair? xx) (+ c 1) c))))))

そうして so-syntax-rules-macro から er-syntax-rules-macro への修正をおこないます。 先頭の rename と compare の内部手続きを消して、 引数で受け取るようにします。 パターン部のリテラルの比較で compare と rename を使うようにします。 リテラルエイリアスを渡しても対応できるようにするため、 syntax-quote は残しておきます。 同様にテンプレート部のリテラルのクォートも rename を使うようにします。 syntax-quote にしておくのも同じです。 テンプレート部では、 もう一ヶ所を変更します。 構文オブジェクトでは so-syntax-vaappend を使っていたところを、 apply append するようにします。 さらに、 末尾を er-macro-transformer を使うように変更します。

-(define (er-syntax-rules-macro expr id)
- (define (rename x) (sc-datum->syntax id x))
- (define compare sc-free-identifier=?)
+(define (er-syntax-rules-macro expr rename compare)
  (define (croak . x) (apply error (append x (list (sc-strip expr)))))
  (define count 0)
  
  ; expand-pattern の sc-identifer? 節
-         (,(rename 'sc-free-identifier=?) ,x (,(rename 'syntax-quote) ,p)) ,(k vars))
+         (,(rename 'compare) ,x (,(rename 'rename) (,(rename 'syntax-quote) ,p))) ,(k vars))

  ; expand-template の sc-identifer? 節
-      (else `(,(rename 'syntax-quote) ,t))))
+      (else `(,(rename 'rename) (,(rename 'syntax-quote) ,t)))))

  ; expand-template の ellipsis? 節
-                            (many nest `(,(rename 'vaappend) ,many)))
+                            (many nest `(,(rename 'apply) ,(rename 'append) ,many)))

  ; 末尾
- `(,(rename 'lambda) (,(rename 'expr)) (,(rename 'cdr) ,(expand-rules expr))))
+ `(,(rename 'er-macro-transformer)
+   (,(rename 'lambda) (,(rename 'expr) ,(rename 'rename) ,(rename 'compare))
+    (,(rename 'cdr) ,(expand-rules expr)))))

これで syntax-rules マクロの変換手続きの変更は終わりです。
展開器に syntax-quote 構文を追加します。

 (define (sc-expand-special denotation form env)
  (let ((keyword (sc-special-name denotation)))
   (case keyword
    ((quote) `(quote ,(sc-strip (cadr form))))
+   ((syntax-quote) `(quote ,(cadr form)))
    ((lambda) (sc-expand-lambda form env))

コア構文環境にも syntax-quote 定義を追加します。

 (define (sc-core-syntactic-environment)
  (let ((env (list '())))
   (sc-define-special 'quote env)
+  (sc-define-special 'syntax-quote env)
   (sc-define-special 'lambda env)

sc-strip に欠けていた vector からの構文情報のそぎおとしを追加します。 この実装の構文クロージャはベクタなので、 構文クロージャ以外のベクタが対象です。

 (define (sc-strip form)
   ((sc-syntactic-closure? form) (sc-strip (sc-syntactic-closure-form form)))
+  ((vector? form) (list->vector (sc-strip (vector->list form))))
   (else form)))

syntax-rules マクロが、 let 構文とラベル付き let 構文へ変換するので、 使えるようにしておきます。

(define (er-let-macro x rename compare)
 (match x
  ((_ (? sc-identifier? tag) ((vars args) ...) body ...)
   `(((,(rename 'lambda) (,tag)
       (,(rename 'set!) ,tag (,(rename 'lambda) (,@vars) ,@body)) ,tag) #f) ,@args))
  ((_ ((vars args) ...) body ...)
    `((,(rename 'lambda) (,@vars) ,@body) ,@args))
  (else (error "no matching" (sc-strip x)))))

同様に and 構文も使えるようにします。

(define (er-and-macro x rename compare)
 (match x
  ((_) #t)
  ((_ e1) e1)
  ((_ #t e2 ...) `(,(rename 'and) ,@e2))
  ((_ e1 e2 ...) `(,(rename 'if) ,e1 (,(rename 'and) ,@e2) #f))
  (else (error "no matching" (sc-strip x)))))

そして、 syntax-rules を定義した構文環境を作ります。

(define (sc-rules-syntactic-environment)
 (let ((syntactic-env (sc-core-syntactic-environment)))
  (sc-define-syntax 'let '(er-macro-transformer er-let-macro) syntactic-env)
  (sc-define-syntax 'and '(er-macro-transformer er-and-macro) syntactic-env)
  (sc-define-syntax 'syntax-rules '(er-macro-transformer er-syntax-rules-macro) syntactic-env)
  (sc-reset-unique-id-counter)
  syntactic-env))

以上で、 構文クロージャな展開器でも syntax-rules を使えるようになります。

(define (demo-r4rs)
 (sc-expand
  '(letrec-syntax
    ((cond (syntax-rules (=>)
            ((_ (e1 => e3)) (let ((t e1)) (if t (e3 t))))
            ((_ (e1 e2 ...)) (if e1 (begin e2 ...))))))
    (let ((=> #t)) (cond (#t => 'ok))))))