syntax-rules, defmacro: define-cxr, define-cxr*

caaaar とか cadadadar などを定義するマクロ。LET OVER LAMBDA Edition 1.0 にもありました。

• scmlib.scm - Gauche/src - Code Search
• Recursive Expansions - Let Over Lambda

取りあえず書いてみました。
組み合わせて作っていく感じ。car + car で caar を作る、みたいな。
以下コード。

	;; define-cxr
	(define-syntax define-cxr
	(syntax-rules ()
	((_ name a b)
	(define (name x)
	((compose a b) x)))))
	(define-cxr my-caar car car)
	(my-caar '((a)))
	;; a
	(define-cxr my-caaar car my-caar)
	(my-caaar '(((a))))
	;; a

view raw define-cxr1.scm hosted with ❤ by GitHub

自分なりに考えてみたもの。もといし、効率も悪いけど意図通り動きます。
こちらは (define-cxr caar) とされたら a と d を car と cdr として手続きを組み立てる感じ。でも入力を制限していないので、my-caaar が caaar 相当の手続きに、ashitahadounaru? が caaadar 相当の手続きになります。。

	(use srfi-1)
	(use gauche.collection)
	;; (symbol->list 'cadar) -> (c a d a r)
	(define (symbol->list sym)
	(map (compose string->symbol string)
	((compose string->list symbol->string) sym)))
	;; (cxr->ad-fun-lis 'cadar) -> (list car cdr car)
	(define (cxr->ad-fun-lis sym)
	(reverse
	(values-ref
	(map-accum
	(lambda (e acc)
	(let1 p (coalesce ((eq? e 'a) car)
	((eq? e 'd) cdr))
	(values p (if p
	(cons p acc)
	acc)))) '() (symbol->list sym)) 1)))
	(define-macro (define-cxr name)
	`(define ,name
	,(apply compose (cxr->ad-fun-lis name))))
	(define-syntax define-cxr*
	(syntax-rules ()
	((_ name ...)
	(begin
	(define-cxr name)
	...
	(values)))))
	(define-cxr cdaaaaaaaaaaaaar)
	;; cdaaaaaaaaaaaaar
	(cdaaaaaaaaaaaaar '((((((((((((((b c)))))))))))))))
	;; (c)
	(define-cxr my-caaar)
	;; my-caaar
	(my-caaar '(((bbb))))
	;; bbb
	(define-cxr my-cdaddaaadr)
	;; my-cdaddaaadr
	(my-cdaddaaadr '(a (((b c (d 1))))))
	;; (1)
	(define-cxr* my-cdar my-cddar my-cdddaar)
	(list my-cdar my-cddar my-cdddaar)
	;; (#<closure (compose compose)> #<closure (compose compose)> #<closure (compose compose)>)

view raw define-cxr2.scm hosted with ❤ by GitHub

• vallog: syntax-rules: coalesce

追記

下のコード貼り間違えてました。修正。

追記2

map-accum でなくてもよかったですね。fold-right でよさそうです。

(define (cxr->ad-fun-lis sym)
  (fold-right (lambda (e acc)
                (let1 p (coalesce ((eq? e 'a) car)
                                  ((eq? e 'd) cdr))
                  (if p
                      (cons p acc)
                      acc))) '() (symbol->list sym)))