健全なマクロ展開 - 変換世代マーク・リスト

ybvig syntax-case で識別子の意味を探すときに、 ラップから抜き出した変換世代マークのリストを使います。 このやりかたを明示リネーミング・マクロに利用するとどうなるのか興味を覚えたので、 試しに Hanson-Bawden に変換世代マークを取り入れてみます。

Gist so-er-expand.scm

手間を省くため、 データ構造には Dybvib の syntax-case のものを流用し、 構文オブジェクトをエイリアスとして使うことにします。 展開の基本動作は Bawden のエイリアスに従います。 展開時構文環境を使い、 ラップに定義時構文環境と変換世代マークを記録しておきます。 いったん記録した後、 ラップが変化しない点が Dybvig syntax-case との違いです。 この合の子展開器では、 展開時構文環境にも変換世代マークを追加します。 両方へのマークの導入により、 識別子の意味を探す方法が syntax-case の流儀に変わります。 展開時構文環境から探し始めて、 途中の適切な場所で定義時構文環境に探す場所を切り替えます。 切り替えのタイミングは展開時構文環境の変換世代マークで決めます。 切り替えた後は、 Dybvig の構文オブジェクトのマーク・リストによる意味探しをおこないます。

識別子はシンボルか構文オブジェクトのどちらかになります。 識別子がシンボルのときのラップとマーク・リストは空リストとします。

(define (so-identifier? x)
 (or (symbol? x) (and (so-syntax-object? x) (symbol? (so-syntax-object-form x)))))

(define (so-identifier-form x)
 (if (symbol? x) x (so-syntax-object-form x)))

(define (so-identifier-wrap x)
 (if (symbol? x) '() (so-syntax-object-wrap x)))

(define (so-identifier-mark* x)
 (if (symbol? x) '() (filter so-mark? (so-syntax-object-wrap x))))

変換世代マークをマクロ摘要ごとに生成し、 展開時構文環境と定義時構文環境の両方をそれで拡張します。

(define (so-expand-macro d form exp-env)
 (let ((mark (make-so-mark)) (table '()))
 (let ((exp-env (so-extend-env mark exp-env))
       (def-env (so-extend-env mark (so-macro-env d))))
 (let ((rename (lambda (x)
        (cond
         ((assq x table) => cdr)
         (else
          (let ((alias (so-extend-wrap def-env x)))
           (set! table (cons (cons x alias) table))
           alias)))))
       (compare (lambda (x y) (so-identifier=? exp-env x exp-env y))))
   (so-expand ((so-macro-proc d) form rename compare) exp-env)))))

構文オブジェクトを so-expand-wrap するとき、 定義時構文環境の先頭にある変換世代マークだけを抜き出してラップに加えます。

(define (so-extend-wrap wrap x)
 (if (so-syntax-object? x)
  (make-so-syntax-object (so-syntax-object-form x)
                         (so-extend-env (car wrap) (so-syntax-object-wrap x)))
  (make-so-syntax-object x wrap)))

識別子が同じ意味かどうかを調べるには構文環境が必要なので、 構文オブジェクトの free-identifier=? ではなく、 構文クロージャの identifier=? とします。

(define (so-identifier=? env1 id1 env2 id2)
 (and (so-identifier? id1) (so-identifier? id2)
  (let ((d1 (so-lookup env1 id1)) (d2 (so-lookup env2 id2)))
   (or (eq? d1 d2)
       (and (so-subst? d1) (so-subst? d2)
        (eq? (so-subst-name d1) (so-subst-name d2)))))))

λ構文と局所マクロ構文で展開時構文環境に追加する環境フレームを作るとき、 キーワードからは、 マークだけを抜き出したリストにします。 一方、 展開時構文環境からマークを取り除いて、 局所マクロの定義時構文環境を作ります。

(define (so-bind-let-syntax keywords forms env)
 (map (lambda (keyword form) (so-bind-id-denotation keyword (so-close-macro form env)))
  keywords forms))

(define (so-bind-id-denotation id denotation)
 (let ((sym (so-identifier-form id))
       (mark* (so-identifier-mark* id)))
  (make-so-binding sym mark* denotation)))

(define (so-close-macro form env)
 (let ((proc (if (procedure? form) form (so-eval-macro-form form env))))
  (if (and (procedure? proc) (eqv? (arity proc) 3))
   (make-so-macro proc (filter so-frame? env))
   (error "macro must be (procedure expr rename compare)" proc))))

λ構文や局所マクロ定義で識別子に意味を持つのは、 マクロが識別子を挿入してから後になります。 それらの後で加えた意味は、 定義時構文環境には含まれず、 展開時構文環境の方に含まれています。 そのため、 識別子を最初に展開時構文環境から探し始めます。 見つからなかったとき、 今度は定義時構文環境から探します。 この意味探索の手順は Hanson-Bawden と同じですけど、 Dybvig のマークを使う手法を援用して、 余計な探索をおこなわないように途中でスキップします。 変換世代マークが生成される前の構文環境には、 そのマークの識別子は存在するはずがないので、 スキップして次のマークによる探索に移ります。 マクロ変換手続き摘要中、 展開時構文環境の先頭と、 リネームした識別子の先頭は同じ変換世代マークがついています。 識別子のマークが 2 つ以上で、 先頭と展開時構文環境の先頭が同じマークのとき、 変換後にλ構文等で環境フレームが追加されていることがあるので、 定義時構文環境の探索に入る前に展開時構文環境から意味を調べておきます。

(define (so-lookup env id)
 (let ((sym (so-identifier-form id)) (mark* (so-identifier-mark* id)))
  (if (and (pair? mark*) (pair? (cdr mark*)) (eq? (car env) (car mark*)))
   (so-lookup-expanding (cdr env) sym (cdr mark*) id)
   (so-lookup-expanding env sym mark* id))))

(define (so-lookup-expanding env sym id-mark* id)
 (let loop ((mark* id-mark*) (env env))
  (cond
   ((null? env) (so-lookup-defined sym id-mark* id))
   ((so-frame? (car env))
    (cond
     ((so-assoc-frame sym mark* (car env)) => so-binding-denotation)
     (else (loop mark* (cdr env)))))
   ((so-mark? (car env))
    (cond
     ((and (pair? mark*) (eq? (car env) (car mark*)))
      (so-lookup-defined sym id-mark* id))
     (else (loop mark* (cdr env)))))
   (else (error "cannot happen so-lookup-expanding")))))

(define (so-lookup-defined sym mark* id)
 (let loop ((mark* mark*) (wrap (so-identifier-wrap id)))
  (cond
   ((null? wrap) (make-so-subst sym))
   ((so-frame? (car wrap))
    (cond
     ((so-assoc-frame sym mark* (car wrap)) => so-binding-denotation)
     (else (loop mark* (cdr wrap)))))
   ((so-mark? (car wrap))
    (cond
     ((and (pair? mark*) (eq? (car wrap) (car mark*)))
      (loop (cdr mark*) (cdr wrap)))
     (else (loop mark* (cdr wrap)))))
   (else (error "cannot happen so-lookup-defined")))))