可読性を求めた quasiquote 展開

Scheme の quasiquote の処理には、 マクロ展開器の中に組み込む Alan Bawden Quasiquatation in Lisp の Appendix B のコードを使うのがてっとり早いのですけど、 このコードの出力する S 式は機械向けです。複雑になると人間には読めたものではないので、 どのように展開するのかを人間が読み取りやすくするように手を加えてみました。 コメントアウトしている 3 つの手続きを使うと、 オリジナルの機械向けに展開した結果を見ることができます。

(define (qq-explain x)
  (define (qq-expand x depth)
    (cond
      ((not (pair? x)) (list 'quote x))
      ((eq? (car x) 'quasiquote)
       (qq-cons ''quasiquote (qq-expand (cdr x) (+ depth 1))))
      ((eq? (car x) 'unquote)
       (cond
        ((> depth 0)
         (qq-cons ''unquote (qq-expand (cdr x) (- depth 1))))
        ((and (not (null? (cdr x))) (null? (cddr x)))
         (cadr x))
        (else (error "Illegal unquote"))))
      ((eq? (car x) 'unquote-splicing)
       (cond
        ((> depth 0)
         (qq-cons ''unquote-splicing (qq-expand (cdr x) (- depth 1))))
        (else (error "Illegal unquote-splicing"))))
      (else
        (qq-append (qq-expand-list (car x) depth) (qq-expand (cdr x) depth)))))

  (define (qq-expand-list x depth)
    (cond
      ((not (pair? x)) (qq-quote-list x))
      ((eq? (car x) 'quasiquote)
       (list 'list (qq-cons ''quasiquote (qq-expand (cdr x) (+ depth 1)))))
      ((eq? (car x) 'unquote)
       (cond
        ((> depth 0)
         (list 'list (qq-cons ''unquote (qq-expand (cdr x) (- depth 1)))))
        (else (cons 'list (cdr x)))))
      ((eq? (car x) 'unquote-splicing)
       (cond
        ((> depth 0)
         (list 'list (qq-cons ''unquote-splicing (qq-expand (cdr x) (- depth 1)))))
        (else (cons 'append (cdr x)))))
      (else
        (list 'list
          (qq-append (qq-expand-list (car x) depth) (qq-expand (cdr x) depth))))))

  (define (tag? x y)
    (and (pair? x) (eq? (car x) y)))

  (define (quoted-nil? x)
    (and (tag? x 'quote) (null? (cadr x))))

  (define (qq-quote-list x)
    (list 'list (list 'quote x)))
  ;(define (qq-quote-list x) (list 'quote (list x)))

  (define (qq-cons x y)
    (cond
      ((tag? y 'list) (cons 'list (cons x (cdr y))))
      ((quoted-nil? y) (list 'list x))
      (else (list 'cons x y))))
  ;(define (qq-cons x y) (list 'cons x y))

  (define (qq-append x y)
    (cond
     ((quoted-nil? y) x)
     ((and (tag? x 'list) (tag? y 'list))
      (cons 'list (append (cdr x) (cdr y))))     
     ((and (tag? x 'append) (null? (cddr x)))
      (list 'append (cadr x) y))
     ((and (tag? x 'list) (null? (cddr x)) (tag? y 'append) (null? (cddr y)))
      (list 'cons (cadr x) (cadr y)))
     ((tag? y 'append)
      (cons 'append (cons x (cdr y))))
     ((tag? y 'cons)
      (list 'append x (list 'list (cadr y)) (caddr y)))
     ((and (tag? x 'list) (null? (cddr x)))
      (list 'cons (cadr x) y))
     (else
      (list 'append x y))))
  ;(define (qq-append x y) (list 'append x y))

  (qq-expand (cadr x) 0))

これを使って Bawden の論文中の例を展開してみます。

gosh> (qq-explain '`x)
'x
gosh> (qq-explain '`,x)
x
gosh> (qq-explain '`',x)
(list 'quote x)
gosh> (qq-explain '``,',x)
(list 'quasiquote (list 'unquote (list 'quote x)))
gosh> (qq-explain '`(x y z))
(list 'x 'y 'z)
gosh> (qq-explain '`(x ,y ,z))
(list 'x y z)
gosh> (qq-explain '`(let ((,x ',v)) ,body))
(list 'let (list (list x (list 'quote v))) body)
gosh> (qq-explain '`(cond ((eq? ,var ',val) ,expr) . ,more-clauses))
(append (list 'cond)
        (list (list (list 'eq? var (list 'quote val)) expr))
        more-clauses)
gosh> (qq-explain '`(cond ((eq? ,var ',val) ,expr) ,@more-clauses (else #t)))
(append (list 'cond)
        (list (list (list 'eq? var (list 'quote val)) expr))
        more-clauses
        (list (list 'else '#t)))
gosh> (qq-explain '`(normal= ,X splicing= ,@X see?))
(append (list 'normal=) (list X) (list 'splicing=) X (list 'see?))
gosh> (write (qq-explain
        '`(define-macro (,abbrev var expr)
            `(,',proc (lambda (,var) ,expr))) ))
(list 'define-macro (list abbrev 'var 'expr)
  (list 'quasiquote (list (list 'unquote (list 'quote proc))
    (list 'lambda (list (list 'unquote 'var)) (list 'unquote 'expr)))))