quasiquote の展開

1年前の「可読性を求めた quasiquote 展開」は、 Alan Bawden Quasiquatation in Lisp の Appendix B のコードを元にしていました。 このコードは、 とても良く似ている 2 つの内部定義手続き qq-expand と qq-expand-list を使って書いてあります。 手続きを一つにまとめたいと誰もが考えるようで、 いくつかバリエーションが生まれています。 それらに、 もう一つ、 付け加えてみます。

2 つの手続きのまとめかたの基本は、 qq-expand のペアの展開の car 部分に qq-expand-list の個々をばらして入れていき、 次の関係を使って簡約していきます。

(append (list x) y) === (cons (car (list x)) y) === (cons x y)
(append x) === x
(append x '()) === x

さらに、 unquote から変換すると (append (list x) y) と見た目がうるさい式を作るのが嫌だったので、 fold-right で等価な式に組み直すよう書き改めました。

(define (expand-quasiquote expr)
 (define rename identity)
 (define compare eq?)
 (define id? symbol?) ; (define id? identifier?)
 (define (tag? tag x) (and (pair? x) (compare (rename tag) (car x))))
 (define (single? tag x) (and (tag? tag x) (pair? (cdr x)) (null? (cddr x))))

 (define (qq x d)
  (cond
   ((null? x) (list (rename 'quote) '()))
   ((id? x) (list (rename 'quote) x))
   ((not (pair? x)) x)
   ((tag? 'quasiquote x)
    (list (rename 'cons) (list (rename 'quote) (car x)) (qq (cdr x) (+ d 1))))
   ((and (> d 0) (or (tag? 'unquote x) (tag? 'unquote-splicing x)))
    (list (rename 'cons) (list (rename 'quote) (car x)) (qq (cdr x) (- d 1))))
   ((and (= d 0) (single? 'unquote x))
    (cadr x))
   ((and (= d 0) (or (tag? 'unquote x) (tag? 'unquote-splicing x)))
    ; (syntax-error "Illegal unquote/unquote-splicing")
    (error "Illegal unquote/unquote-splicing"))
   ((and (= d 0) (single? 'unquote-splicing (car x)) (null? (cdr x)))
    (cadar x))
   ((and (= d 0) (tag? 'unquote (car x)))
    ; (list (rename 'append) (cons (rename 'list) (cdar x)) (qq (cdr x) d))
    (fold-right (lambda (e r) (list (rename 'cons) e r)) (qq (cdr x) d) (cdar x)))
   ((and (= d 0) (tag? 'unquote-splicing (car x)))
    ; (list (rename 'append) (cons (rename 'append) (cdar x)) (qq (cdr x) d))
    (fold-right (lambda (e r) (list (rename 'append) e r)) (qq (cdr x) d) (cdar x)))
   (else (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))

 (qq (cadr expr) 0))