cxxxxr の定義を作る

match の移植の時 caddadr 手続き的なものが必要で手書きしていたんですが一ヶ所 a と d を書き間違えてひどい目にあいました。
というわけで定義を生成するような手続きを書いてみました。いまいちスマートな方法が思いつかず。リスト同士の操作はもっとうまくできる手続きがありそうなのだけどなあ。

(define (gen-cxxr n)
  (define (association lst1 lst2)
    (fold-right (lambda (x y) (append (map (cut cons x <>) lst2) y)) '() lst1))
  (define (combination n)
    (let loop ([n (- n 1)])
      (if (<= n 0)
          '((a) (d))
          (association '(a d) (loop (- n 1))))))
  (define (gen lst)
    (let loop ([name ""]
               [body "p"]
               [lst lst])
      (if (null? lst)
          (format #t "(define (c~ar p) ~a)\n" name body)
          (loop (format "~a~a" (car lst) name)
                (format "(~a ~a)" (if (eq? 'a (car lst)) 'car 'cdr) body)
                (cdr lst)))))
  (let loop ([m 2])
    (cond
     [(< n m) '()]
     [else
      (for-each gen (combination m))
      (loop (+ m 1))])))

(gen-cxxr 3)
=>
(define (caar p) (car (car p)))
(define (cdar p) (cdr (car p)))
(define (cadr p) (car (cdr p)))
(define (cddr p) (cdr (cdr p)))
(define (caaar p) (car (car (car p))))
(define (cdaar p) (cdr (car (car p))))
(define (cadar p) (car (cdr (car p))))
(define (cddar p) (cdr (cdr (car p))))
(define (caadr p) (car (car (cdr p))))
(define (cdadr p) (cdr (car (cdr p))))
(define (caddr p) (car (cdr (cdr p))))
(define (cdddr p) (cdr (cdr (cdr p))))

あとから気づいたが、どう書く？orgに書けば良かったλ...。

そういえば　cxxxxr 系の手続きが呼ばれてその定義が処理系に存在しなかったら動的に作るみたいな処理系があるとわだぱさん（？）に教えてもらったのですが、今度やってみようかな。
method-missing 的なあれで。