Tociyuki::Diary RSSフィード

tociyuki による Perl・Ruby・C++・C で書き散らしたコードを中心に、日常雑記も混在 : B  F  twitter  GitHub  CPAN  本館  公開鍵
 | 

2018年01月24日

[]健全なマクロ展開 - Clinger-Rees の明示リネーミング・マクロ (その2)

W. Clinger、 J. Rees、 Macros That Work (1991) のアルゴリズムになるべく沿って展開器を書いてみます。 明示リネーミング・マクロとしては W. Clinger, Hygienic Macros Through Explicit Renaming (1991) に沿います。 相変わらず、 Gauche 0.9.5 にべったり依存したコードになっています。

2018 年 1 月 25 日改訂: cr-identifier=? 手続きを仕様通りに書き直しました。 特殊形式の special denotation へ定義時環境を追加しました。 let-syntax と letrec-syntax をキーワードと変換子の式を健全に展開してから評価して変換子を作るようにしました。

Gist tociyuki/cr-er-expand.scm

展開器のエントリ・ポイントの cr-expand は、 syntactic-closures のものと良く似ています。 違うところは、 特殊形式であるかどうかを、 展開時構文環境からシンボルで special denotation が得られかどうかで判断している点です。

(use util.match)

(define (cr-expand form env)
 (cond
  ((symbol? form)
   (let ((denotation (cr-lookup form env)))
    (cond
     ((cr-macro? denotation) (cr-expand-macro denotation form env))
     ((cr-subst? denotation) (cr-subst-name denotation))
     ((cr-special? denotation) (cr-special-name denotation))
     (else (error "cr-expander: cannot happen" denotation)))))
  ((and (pair? form) (symbol? (car form)))
   (let ((denotation (cr-lookup (car form) env)))
    (cond
     ((cr-macro? denotation) (cr-expand-macro denotation form env))
     ((cr-special? denotation) (cr-expand-special denotation form env))
     (else (cr-expand-list form env)))))
  ((pair? form) (cr-expand-list form env))
  (else form)))

(define (cr-expand-list form* env)
 (map (lambda (form) (cr-expand form env)) form*))

Denotation は 4 種類あります。変数置換規則のための subst、 特殊形式のための special、 マクロ変換子のための macro、 そして、 リネーム前のシンボルを記録する renameです。

;  Denotation : (subst . Variable)
;             | (special Keyword . 定義時構文環境)
;             | (macro Procedure . 定義時構文環境)
;             | (rename Identifier . Denotation)
(define (cr-record-denotation kind)
 (lambda spec
  (cons kind (apply cons* spec))))

(define (cr-record-denotation-kind? kind)
 (lambda (x)
  (and (pair? x) (eq? (car x) kind))))

(define make-cr-subst (cr-record-denotation 'subst))       ; 変数置換規則
(define cr-subst? (cr-record-denotation-kind? 'subst))
(define cr-subst-name cdr)
(define make-cr-special (cr-record-denotation 'special))   ; 特殊形式
(define cr-special? (cr-record-denotation-kind? 'special))
(define cr-special-name cadr)
(define cr-special-env cddr)
(define make-cr-macro (cr-record-denotation 'macro))       ; マクロ変換子
(define cr-macro? (cr-record-denotation-kind? 'macro))
(define cr-macro-proc cadr)
(define cr-macro-env cddr)
(define make-cr-rename (cr-record-denotation 'rename))     ; rename ラッパー
(define cr-rename? (cr-record-denotation-kind? 'rename))
(define cr-rename-identifier cadr)
(define cr-rename-denotation cddr)

cr-lookup で、 シンボルに結ばれている denotation を求めます。 rename denotation はオリジナルの Clinger-Rees アルゴリズムにはないもので、 quote の desyntaxify 処理のために追加したものです。 それ以外では rename denotation は透明で、 cr-lookup は rename denotation に結びつけてある他の denotation を返します。 構文環境にシンボルが見つからないときは、 シンボルそれ自身への変数置換規則を返すことにしておきます。

(define (cr-lookup x env)
 (let ((apair (cr-assoc-env x env)))
  (if apair
   (cr-prune-denotation (cdr apair))
   (make-cr-subst x)))) ; 見つからなかったときはシンボル x 自身への置換規則にします。

(define (cr-prune-denotation denotation)
 (if (cr-rename? denotation)
  (cr-prune-denotation (cr-rename-denotation denotation))
  denotation))

一方、 cr-assoc-env は構文環境から束縛対を探して返します。 こちらは、 rename denotation もそのまま返します。

; 構文環境 : (((Symbol . Denotation) ...) ...)
(define (cr-assoc-env x env)
 (let loop ((env env))
  (cond
   ((null? env) #f)
   ((pair? env) (or (assq x (car env)) (loop (cdr env))))
   (else (error "cr-assoc-env: cannot happen" x env)))))

マクロ・アプリケーションは、 ユニークな番号 uid でシンボルをリネームする準備をします。 リネーム時にシンボルと rename denotation を追加するために、 構文環境へ空のフレームを追加しておきます。 準備ができたら、 変換手続きを呼びます。 そして、 変換後の式を rename denotation を追加した展開時環境でさらに展開します。

(define (cr-expand-macro mac form env)
 (let ((uid (cr-generate-uid))
       (def-env (cr-macro-env mac))
       (exp-env (cons '() env)))
 (let ((rename (cr-identifier-rename uid exp-env def-env))
       (compare (lambda (x1 x2) (cr-identifier=? exp-env x1 exp-env x2))))
  (cr-expand ((cr-macro-proc mac) form rename compare) exp-env))))

ユニークな番号 uid は cr-generate-uid で生成します。

(define cr-unique-id-counter 0)
(define (cr-reset-unique-id-counter) (set! cr-unique-id-counter 0))

(define (cr-generate-uid)
 (set! cr-unique-id-counter (+ cr-unique-id-counter 1))
 cr-unique-id-counter)

cr-identifier-rename で、 rename 手続きを作ります。 rename 手続きは、 リネーム前シンボル x の rename denotation を展開時構文環境の先頭フレームに追加する働きを担います。 追加するときに、 新しいシンボル x.n を uid を使って生成して、 rename x denotation と結びつけます。 さらに、 変換子の定義時構文環境から x に結びつく denotation d を得て、 rename x denotation に登録します。 cr-lookup は、 x が見つからないときでも subst x denotation を返すことを頭に入れておくと良いでしょう。 これにより、 リネームされたシンボル x.n は、 リネーム前のシンボル x に対する denotation を必ず定義時構文環境だけから探すことになります。 見つからなかったときに、 展開時構文環境から探し直すことはしません。 先頭フレームに既に追加済みのときは、 リネームしたシンボル x.n を返します。

(define (cr-identifier-rename uid exp-env def-env)
 ; E (F0 F1 ...) -> (((x.n rename x . d) . F0) F1 ...)
 ; d は (cr-lookup x def-enf) で得た denotation
 (lambda (x)
  (let loop ((frame (car exp-env)))
   (cond
    ((pair? frame)
     (if (eq? x (cr-rename-identifier (cdar frame)))
      (caar frame)  ; 既に追加済みなので、 x.n を返します。
      (loop (cdr frame))))
    ((null? frame)
     (let ((x.n (cr-gen-var x uid))
           (denotation (cr-lookup x def-env)))
      (set-car! exp-env (cons (cons x.n (make-cr-rename x denotation)) (car exp-env)))
      x.n))
    (else (error "cr-identifier-rename: cannot happen" (car exp-env)))))))

cr-gen-var で、 シンボルと uid から、 新しくシンボルを作ります。

(define (cr-gen-var sym uid)
 (string->symbol
  (string-append
   (symbol->string sym)
   "."
   (number->string uid))))

compare 手続きが使う、 cr-identifier=? では、 それぞれの構文環境下で識別子が同じ意味をもつかどうかを調べます。 置換規則のときは、 同じ束縛変数シンボルへ置換するときを同じ意味とします。 それ以外のときは、 特殊形式か変換子の場合であり、 どちらの場合も denotation が eq? のときだけ同じ意味であるということにしておきました。

(define (cr-identifier=? env1 x1 env2 x2)
 (and (symbol? x1) (symbol? x2)
  (or (eq? x1 x2)
   (let ((denotation1 (cr-lookup x1 env1))
         (denotation2 (cr-lookup x2 env2)))
    (or (eq? denotation1 denotation2)
     (and (cr-subst? denotation1) (cr-subst? denotation2)
      (eq? (cr-subst-name denotation1) (cr-subst-name denotation2))))))))

展開器に戻り、 特殊形式の展開器を見てみます。 if 等のキーワードはリネームされていることがあるので、 元に戻しておきます。 特殊形式の定義時環境は let-syntax と letrec-syntax が展開時に比較するシンボルが定義時と同じ意味で使われているかどうか調べるのに利用します。

(define (cr-expand-special denotation form env)
 (let ((keyword (cr-special-name denotation)))
  (case keyword
   ((quote) form)
   ((lambda) (cr-expand-lambda form env))
   ((let-syntax) (cr-expand-let-syntax form env (cr-special-env denotation)))
   ((letrec-syntax) (cr-expand-letrec-syntax form env (cr-special-env denotation)))
   ((if set! begin) `(,keyword ,@(cr-expand-list (cdr form) env)))
   (else (error "unknown special form" form)))))

cr-lookup-identifier はリネーム前の識別子を求める処理をします。 たぶん、 理屈上で、 このやりかたで求まるはずですけど、 間違えているかもしれません。

(define (cr-lookup-identifier x env)
 (let ((apair (cr-assoc-env x env)))
  (if apair
   (let ((denotation (cdr apair)))
    (if (cr-rename? denotation)
     (cr-lookup-identifier (cr-rename-identifier denotation) env)
     x))
   x)))

λ構文では、 束縛変数のシンボル x.n を新しく作って、 元の識別子 x から x.n への置換規則を展開時構文環境に追加します。 リネームされたシンボルが束縛変数になるとき、 見やすさからリネーム前の識別子に uid をつけるようにしていますけど、 処理速度を優先するなら、 リネームされたシンボルに uid をさらにつけてもかまわないのかもしれません。

(define (cr-expand-lambda form env)
 (match form
  ((_ (idents ...) body ...)
   (cr-syntactic-env-subst idents env (lambda (vars env)
    `(lambda ,vars ,@(cr-expand-list body env)))))))

(define (cr-syntactic-env-subst idents env kont)
 (let* ((uid (cr-generate-uid))
        (vars (map (lambda (x) (cr-gen-var (cr-lookup-identifier x env) uid)) idents))
        (frame (map (lambda (x x.i) (cons x (make-cr-subst x.i))) idents vars)))
  (kont vars (cons frame env))))

let-syntax は、 マクロ変換式から変換子を作ってから、 展開時構文環境に追加し、 追加した展開時構文環境下で本体の展開をおこないます。 なお、 ここの let-syntax の定義時構文環境とは、 let-syntax 自身の special denotation を定義してある構文環境のことです。

(define (cr-expand-let-syntax form exp-env def-env)
 (match form
  ((_ ((keywords transformers) ...) body ...)
   (let ((frame (cr-bind-syntax keywords transformers exp-env)))
   (let ((exp-env (cons frame exp-env)))
    (if (null? (cdr body))
     (cr-expand (car body) exp-env)
     `(begin ,@(cr-expand-list body exp-env))))))))

一方、 letrec-syntax は、 展開時構文環境にダミー・フレームを追加しておいてから、 追加した展開時環境下でマクロ変換式から変換子を作ってからダミー・フレームと入れ換えます。 そして、 本体をフレームを入れ換えた展開時環境下で展開します。

(define (cr-expand-letrec-syntax form exp-env def-env)
 (match form
  ((_ ((keywords transformers) ...) body ...)
   (let ((exp-env (cons (cr-bind-dummy-frame keywords) exp-env)))
   (let ((frame (cr-bind-syntax keywords transformers exp-env)))
    (set-car! exp-env frame)
    (if (null? (cdr body))
     (cr-expand (car body) exp-env)
     `(begin ,@(cr-expand-list body exp-env))))))))

(define (cr-bind-dummy-frame keywords)
 (map (lambda (x) (cons x (make-cr-subst x))) keywords))

let-syntax と letrec-syntax は、 補助手続きを使って変換子のフレームを作成します。

(define (cr-bind-syntax keywords transformers exp-env)
 (map cons
  (map (lambda (kw) (cr-expand kw exp-env)) keywords)
  (map (lambda (form) (cr-close-macro form exp-env)) transformers)))

式を評価して変換手続きを得る cr-close-macro は、 構文クロージャと同じです。 マクロ展開したものをホストの環境で評価します。

(define cr-macro-proc-environment (interaction-environment))

(define (cr-close-macro form exp-env)
 (let ((proc (cr-eval-macro-form form exp-env)))
  (if (and (procedure? proc) (let ((i (arity proc))) (and (number? i) (= i 3))))
   (make-cr-macro proc exp-env)
   (error "macro must be procedure" form))))

(define (cr-eval-macro-form form exp-env)
 (eval (cr-expand form exp-env) cr-macro-proc-environment))

(define (er-macro-transformer proc) proc)

デフォルト構文環境に特殊形式とマクロを定義するための手続きも用意しておきます。 マクロを定義するとき、 cr-expand で展開した式を評価して変換手続きを作ります。

(define (cr-define x denotation env)
 (set-car! env (cons (cons x denotation) (car env)))
 x)

(define (cr-define-special kw env)
 (cr-define kw (make-cr-special kw env) env))

(define (cr-define-syntax kw form exp-env)
 (cr-define kw (cr-close-macro form exp-env) exp-env))

コアの構文環境はフレームを一つだけ持ち、 そこに特殊形式の denotation を書き込んでおきます。

(define (cr-core-syntactic-environment)
 (let ((env (list '())))
  (cr-define-special 'quote env)
  (cr-define-special 'lambda env)
  (cr-define-special 'let-syntax env)
  (cr-define-special 'letrec-syntax env)
  (cr-define-special 'if env)
  (cr-define-special 'set! env)
  (cr-define-special 'begin env)
  env))

コア構文環境へ let 構文と or 構文を追加した構文環境も利用できるようにしておきます。 let 構文をλ構文へ変換するとき、 lambda シンボルをクォートしてあるので、 疑似クォート構文を使うことができる点が syntactic-closures よりも扱いやすくて助かります。

(define (cr-scheme-syntactic-environment)
 (let ((syntactic-env (cr-core-syntactic-environment)))
  (cr-define-syntax 'let
   '(er-macro-transformer
     (lambda (form rename compare)
      ((lambda (vars args body)
        `((,(rename 'lambda) ,vars ,@body) ,@args))
       (map car (cadr form))
       (map cadr (cadr form))
       (cddr form))))
   syntactic-env)
  (cr-define-syntax 'or
   '(er-macro-transformer
     (lambda (form rename compare)
      (if (null? (cdr form))
       #f
       (if (null? (cddr form))
        (cadr form)
        `(,(rename 'let) ((,(rename 'temp) ,(cadr form)))
          (,(rename 'if) ,(rename 'temp)
           ,(rename 'temp)
           (,(rename 'or) ,@(cddr form))))))))
   syntactic-env)
  syntactic-env))

例えば、 let 構文と or 構文を追加した構文環境を使って展開するには次のようにします。

(define (demo1)
 (let ((syntactic-env (cr-scheme-syntactic-environment)))
  (cr-reset-unique-id-counter)
  (cr-expand
   '((lambda (x) (let ((if list) (temp x)) (or 1 temp))) 2)
   syntactic-env)))

もちろん、 コア構文環境で letrec-syntax を使って展開しても同じ結果になります。

(define (demo2)
 (let ((syntactic-env (cr-core-syntactic-environment)))
  (cr-reset-unique-id-counter)
  (cr-expand
   '(let-syntax
     ((let
       (er-macro-transformer
        (lambda (form rename compare)
         ((lambda (vars args body)
           `((,(rename 'lambda) ,vars ,@body) ,@args))
          (map car (cadr form))
          (map cadr (cadr form))
          (cddr form))))))
      (letrec-syntax
       ((or
         (er-macro-transformer
          (lambda (form rename compare)
           (if (null? (cdr form))
            #f
            (if (null? (cddr form))
             (cadr form)
             `(,(rename 'let) ((,(rename 'temp) ,(cadr form)))
               (,(rename 'if) ,(rename 'temp)
                ,(rename 'temp)
                (,(rename 'or) ,@(cddr form))))))))))
       ((lambda (x) (let ((if list) (temp x)) (or 1 temp))) 2)))
   syntactic-env)))

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/tociyuki/20180124/1516794682
 |